File Coverage

File:lib/Netspoc.pm
Coverage:81.3%

linestmtbrancondsubpodtimecode
1package Netspoc;
2
3 - 27
=head1 NAME

Netspoc - A Network Security Policy Compiler

=head1 COPYRIGHT AND DISCLAIMER

(c) 2015 by Heinz Knutzen <heinz.knutzen@googlemail.com>

http://hknutzen.github.com/Netspoc

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=cut
28
29
70
70
70
233
71
1656
use strict;
30
70
70
70
257
67
1544
use warnings;
31
70
70
70
16874
134
4632
use Module::Load::Conditional qw(can_load);
32my $can_json = can_load( modules => {JSON => 0.0} ) and JSON->import();
33
70
70
70
11955
115
228
use open qw(:std :utf8);
34
70
70
70
16032
94
5311
use Encode;
35my $filename_encode = 'UTF-8';
36
37# VERSION: inserted by DZP::OurPkgVersion
38my $program = 'Network Security Policy Compiler';
39my $version = __PACKAGE__->VERSION || 'devel';
40
41
70
70
70
272
74
1757714
use Exporter;
42our @ISA    = qw(Exporter);
43our @EXPORT = qw(
44  %routers
45  %interfaces
46  %networks
47  %hosts
48  %owners
49  %areas
50  %pathrestrictions
51  %groups
52  %protocols
53  %protocolgroups
54  %services
55  %isakmp
56  %ipsec
57  %crypto
58  %expanded_rules
59  $error_counter
60  store_description
61  fast_mode
62  get_config_keys
63  get_config_pattern
64  check_config_pair
65  read_config
66  set_config
67  info
68  progress
69  abort_on_error
70  set_abort_immediately
71  err_msg
72  fatal_err
73  unique
74  equal
75  read_ip
76  print_ip
77  show_version
78  split_typed_name
79  is_network
80  is_router
81  is_interface
82  is_host
83  is_subnet
84  is_every
85  is_group
86  is_protocolgroup
87  is_objectgroup
88  is_chain
89  is_autointerface
90  read_netspoc
91  read_file
92  read_file_or_dir
93  show_read_statistics
94  order_protocols
95  link_topology
96  mark_disabled
97  set_zone
98  set_service_owner
99  expand_services
100  expand_crypto
101  check_unused_groups
102  setpath
103  path_walk
104  find_active_routes_and_statics
105  check_supernet_rules
106  optimize_and_warn_deleted
107  distribute_nat_info
108  gen_reverse_rules
109  mark_secondary_rules
110  rules_distribution
111  local_optimization
112  check_output_dir
113  print_code );
114
115####################################################################
116# User configurable options.
117####################################################################
118
119# Valid values:
120# - Default: 0|1
121# - Option with name "check_*": 0,1,'warn'
122#  - 0: no check
123#  - 1: throw an error if check fails
124#  - warn: print warning if check fails
125# - Option with name "max_*": integer
126# Other: string
127our %config = (
128
129# Check for unused groups and protocolgroups.
130    check_unused_groups => 'warn',
131
132# Check for unused protocol definitions.
133    check_unused_protocols => 0,
134
135# Allow subnets only
136# - if the enclosing network is marked as 'has_subnets' or
137# - if the subnet is marked as 'subnet_of'
138    check_subnets => 'warn',
139
140# Check for unenforceable rules, i.e. no managed device between src and dst.
141    check_unenforceable => 'warn',
142
143# Check for duplicate rules.
144    check_duplicate_rules => 'warn',
145
146# Check for redundant rules.
147    check_redundant_rules => 'warn',
148
149# Check for services where owner can't be derived.
150    check_service_unknown_owner => 0,
151
152# Check for services where multiple owners have been derived.
153    check_service_multi_owner => 'warn',
154
155# Check for missing supernet rules.
156    check_supernet_rules => 'warn',
157
158# Check for transient supernet rules.
159    check_transient_supernet_rules => 'warn',
160
161# Optimize the number of routing entries per router:
162# For each router find the hop, where the largest
163# number of routing entries points to
164# and replace them with a single default route.
165# This is only applicable for internal networks
166# which have no default route to the internet.
167    auto_default_route => 1,
168
169# Add comments to generated code.
170    comment_acls   => 0,
171    comment_routes => 0,
172
173# Ignore these names when reading directories:
174# - CVS and RCS directories
175# - CVS working files
176# - Editor backup files: emacs: *~
177    ignore_files => '^(CVS|RCS|\.#.*|.*~)$',
178
179# Abort after this many errors.
180    max_errors => 10,
181
182# Print progress messages.
183    verbose => 1,
184
185# Print progress messages with time stamps.
186# Print "finished" with time stamp when finished.
187    time_stamps => 0,
188);
189
190# Valid values for config options in %config.
191# Key is prefix or string "default".
192# Value is pattern for checking valid values.
193our %config_type = (
194    check_   => '0|1|warn',
195    max_     => '\d+',
196    ignore_  => '\S+',
197    _default => '0|1',
198);
199
200sub get_config_keys {
201
305
0
1236
    return keys %config;
202}
203
204sub valid_config_key {
205
0
0
0
    my ($key) = @_;
206
0
0
    return exists $config{$key};
207}
208
209sub get_config_pattern {
210
5188
0
4322
    my ($key) = @_;
211
5188
3591
    my $pattern;
212
5188
8013
    for my $prefix (keys %config_type) {
213
15358
108320
        if ($key =~ /^$prefix/) {
214
3662
3901
            $pattern = $config_type{$prefix};
215
3662
3810
            last;
216        }
217    }
218
5188
15648
    return $pattern || $config_type{_default};
219}
220
221# Checks for valid config key/value pair.
222# Returns false on success, the expected pattern on failure.
223sub check_config_pair {
224
3
0
5
    my ($key, $value) = @_;
225
3
4
    my $pattern = get_config_pattern($key);
226
3
93
    return ($value =~ /^($pattern)$/ ? undef : $pattern);
227}
228
229# Set %config with pairs from one or more hashrefs.
230# Rightmost hash overrides previous values with same key.
231sub set_config {
232
337
0
475
    my (@hrefs) = @_;
233
337
438
    for my $href (@hrefs) {
234
663
1722
        while (my ($key, $val) = each %$href) {
235
388
1274
            $config{$key} = $val;
236        }
237    }
238
337
514
    return;
239}
240
241# Modified only by sub store_description.
242my $new_store_description;
243
244sub store_description {
245
13
0
18
    my ($set) = @_;
246
13
27
    if (defined $set) {
247
11
18
        return($new_store_description = $set);
248    }
249    else {
250
2
5
        return $new_store_description;
251    }
252}
253
254my $fast_mode;
255sub fast_mode {
256
947
0
899
    my ($set) = @_;
257
947
1278
    if (defined $set) {
258
305
360
        return($fast_mode = $set);
259    }
260    else {
261
642
1328
        return $fast_mode;
262    }
263}
264
265# Use non-local function exit for efficiency.
266# Perl profiler doesn't work if this is active.
267my $use_nonlocal_exit => 1;
268
269####################################################################
270# Attributes of supported router models
271####################################################################
272my %router_info = (
273    IOS => {
274        routing             => 'IOS',
275        filter              => 'IOS',
276        stateless           => 1,
277        stateless_self      => 1,
278        stateless_icmp      => 1,
279        inversed_acl_mask   => 1,
280        can_vrf             => 1,
281        can_log_deny        => 1,
282        log_modifiers       => { 'log-input' => ':subst' },
283        has_out_acl         => 1,
284        need_protect        => 1,
285        crypto              => 'IOS',
286        print_interface     => 1,
287        comment_char        => '!',
288        extension           => {
289            EZVPN => { crypto    => 'EZVPN' },
290            FW    => { stateless => 0 },
291        },
292    },
293    'NX-OS' => {
294        routing             => 'NX-OS',
295        filter              => 'NX-OS',
296        stateless           => 1,
297        stateless_self      => 1,
298        stateless_icmp      => 1,
299        can_objectgroup     => 1,
300        inversed_acl_mask   => 1,
301        use_prefix          => 1,
302        can_vrf             => 1,
303        can_log_deny        => 1,
304        log_modifiers       => {},
305        has_out_acl         => 1,
306        need_protect        => 1,
307        print_interface     => 1,
308        comment_char        => '!',
309    },
310    'ACE' => {
311        routing             => 'IOS',
312        filter              => 'ACE',
313        stateless           => 0,
314        stateless_self      => 0,
315        stateless_icmp      => 1,
316        can_objectgroup     => 1,
317        inversed_acl_mask   => 0,
318        use_prefix          => 0,
319        can_vrf             => 0,
320        can_log_deny        => 0,
321        log_modifiers       => {},
322        has_vip             => 1,
323        has_out_acl         => 1,
324        need_protect        => 1,
325        print_interface     => 1,
326        comment_char        => '!',
327    },
328    PIX => {
329        routing             => 'PIX',
330        filter              => 'PIX',
331        stateless_icmp      => 1,
332        can_objectgroup     => 1,
333        comment_char        => '!',
334        has_interface_level => 1,
335        need_identity_nat   => 1,
336        no_filter_icmp_code => 1,
337        need_acl            => 1,
338    },
339
340    # Like PIX, but without identity NAT.
341    ASA => {
342        routing             => 'PIX',
343        filter              => 'PIX',
344        log_modifiers       => { emergencies   => 0,
345                                 alerts        => 1,
346                                 critical      => 2,
347                                 errors        => 3,
348                                 warnings      => 4,
349                                 notifications => 5,
350                                 informational => 6,
351                                 debugging     => 7,
352                                 disable       => 'disable',
353                               },
354        stateless_icmp      => 1,
355        has_out_acl         => 1,
356        can_objectgroup     => 1,
357        can_dyn_crypto      => 1,
358        crypto              => 'ASA',
359        no_crypto_filter    => 1,
360        comment_char        => '!',
361        has_interface_level => 1,
362        no_filter_icmp_code => 1,
363        need_acl            => 1,
364        extension           => {
365            VPN => {
366                crypto           => 'ASA_VPN',
367                stateless_tunnel => 1,
368                do_auth          => 1,
369            },
370            EZVPN => { crypto    => 'ASA_EZVPN' },
371            '8.4' => { v8_4 => 1, },
372        },
373    },
374    Linux => {
375        routing          => 'iproute',
376        filter           => 'iptables',
377        has_io_acl       => 1,
378        comment_char     => '#',
379        can_managed_host => 1,
380    },
381);
382for my $model (keys %router_info) {
383
384    # Is changed for model with extension. Used in error messages.
385    $router_info{$model}->{name} = $model;
386
387    # Is left unchanged with extensions. Used in header of generated files.
388    $router_info{$model}->{class} = $model;
389}
390
391# Use this if src or dst port isn't defined.
392# Don't allocate memory again and again.
393my $aref_tcp_any = [ 1, 65535 ];
394
395# Definition of dynamic routing protocols.
396# Protocols get {up} relation in order_protocols.
397my %routing_info;
398
399# Definition of redundancy protocols.
400# Protocols get {up} relation in order_protocols.
401my %xxrp_info;
402
403## no critic (RequireArgUnpacking)
404
405# All arguments are 'eq'.
406sub equal {
407
53
0
108
    return 1 if not @_;
408
43
39
    my $first = shift;
409
43
47
56
167
    return not grep { $_ ne $first } @_;
410}
411
412# Unique union of all elements.
413# Preserves original order.
414sub unique {
415
1062
0
844
    my %seen;
416
1062
1091
1418
4947
    return grep { !$seen{$_}++ } @_;
417}
418
419sub find_duplicates {
420
67
0
58
    my %dupl;
421
67
183
    $dupl{$_}++ for @_;
422
67
77
119
291
    return grep { $dupl{$_} > 1 } keys %dupl;
423}
424
425sub intersect {
426
3
0
4
    my ($aref1, $aref2) = @_;
427
3
3
3
9
    my %seen = map { $_ => 1 } @$aref1;
428
3
3
3
9
    return grep { $seen{$_} } @$aref2;
429}
430
431sub max {
432
0
0
0
    my $max = shift(@_);
433
0
0
    for my $el (@_) {
434
0
0
        $max = $el if $max < $el;
435    }
436
0
0
    return $max;
437}
438
439# Delete an element from an array reference.
440# Return 1 if found, undef otherwise.
441sub aref_delete {
442
163
0
154
    my ($aref, $elt) = @_;
443
163
283
    for (my $i = 0 ; $i < @$aref ; $i++) {
444
199
421
        if ($aref->[$i] eq $elt) {
445
163
172
            splice @$aref, $i, 1;
446
447#debug("aref_delete: $elt->{name}");
448
163
292
            return 1;
449        }
450    }
451
0
0
    return;
452}
453
454# Compare two array references element wise.
455sub aref_eq  {
456
1390
0
1186
    my ($a1, $a2) = @_;
457
1390
2474
    return if @$a1 ne @$a2;
458
1131
1867
    for (my $i = 0 ; $i < @$a1 ; $i++) {
459
98
244
        return if $a1->[$i] ne $a2->[$i];
460    }
461
1109
1622
    return 1;
462}
463
464sub keys_eq {
465
36
0
40
    my ($href1, $href2) = @_;
466
36
80
    keys %$href1 == keys %$href2 or return;
467
22
37
    for my $key (keys %$href1) {
468
25
65
        exists $href2->{$key} or return;
469    }
470
16
42
    return 1;
471}
472
473my $start_time;
474
475sub info {
476
1542
0
2558
    return if not $config{verbose};
477
0
0
    print STDERR @_, "\n";
478
0
0
    return;
479}
480
481sub progress {
482
6727
0
11206
    return if not $config{verbose};
483
0
0
    if ($config{time_stamps}) {
484
0
0
        my $diff = time() - $start_time;
485
0
0
        printf STDERR "%3ds ", $diff;
486    }
487
0
0
    info(@_);
488
0
0
    return;
489}
490
491sub warn_msg {
492
72
0
1492
    print STDERR "Warning: ", @_, "\n";
493
72
171
    return;
494}
495
496sub debug {
497
0
0
0
    return if not $config{verbose};
498
0
0
    print STDERR @_, "\n";
499
0
0
    return;
500}
501## use critic
502
503# Name of current input file.
504our $current_file;
505
506# Rules and objects read from directories and files with
507# special name 'xxx.private' are marked with attribute {private} = 'xxx'.
508# This variable is used to propagate the value from directories to its
509# files and sub-directories.
510our $private;
511
512# Content of current file.
513our $input;
514
515# Current line number of input file.
516our $line;
517
518sub context {
519
0
0
0
    my $context;
520
0
0
    if (pos $input == length $input) {
521
0
0
        $context = 'at EOF';
522    }
523    else {
524
0
0
        my ($pre, $post) =
525          $input =~ m/([^ \t\n,;={}]*[,;={} \t]*)\G([,;={} \t]*[^ \t\n,;={}]*)/;
526
0
0
        $context = qq/near "$pre<--HERE-->$post"/;
527    }
528
0
0
    return qq/ at line $line of $current_file, $context\n/;
529}
530
531sub at_line {
532
12
0
299
    return qq/ at line $line of $current_file\n/;
533}
534
535our $error_counter;
536our $abort_immediately;
537
538sub check_abort {
539
124
0
112
    $error_counter++;
540
124
355
    if ($error_counter == $config{max_errors}) {
541
0
0
        die "Aborted after $error_counter errors\n";
542    }
543    elsif ($abort_immediately) {
544
0
0
        die "Aborted\n";
545    }
546}
547
548sub abort_on_error {
549
542
0
1270
    die "Aborted with $error_counter error(s)\n" if $error_counter;
550
450
390
    return;
551}
552
553sub set_abort_immediately {
554
208
0
176
    $abort_immediately = 1;
555
208
172
    return;
556}
557
558sub error_atline {
559
12
0
19
    my (@args) = @_;
560
12
24
    print STDERR "Error: ", @args, at_line();
561
12
23
    check_abort();
562
12
16
    return;
563}
564
565sub err_msg {
566
112
0
186
    my (@args) = @_;
567
112
2811
    print STDERR "Error: ", @args, "\n";
568
112
180
    check_abort();
569
112
241
    return;
570}
571
572sub fatal_err {
573
5
0
6
    my (@args) = @_;
574
5
55
    print STDERR "Error: ", @args, "\n";
575
5
27
    die "Aborted\n";
576}
577
578sub syntax_err {
579
0
0
0
    my (@args) = @_;
580
0
0
    die "Syntax error: ", @args, context();
581}
582
583sub internal_err {
584
0
0
0
    my (@args) = @_;
585
586    # Don't show inherited error.
587    # Abort immediately, if other errors have already occured.
588
0
0
    if ($error_counter) {
589
0
0
        die "Aborted after $error_counter errors\n";
590    }
591
0
0
    my (undef, $file, $line) = caller;
592
0
0
    my $sub = (caller 1)[3];
593
0
0
    my $msg = "Internal error in $sub";
594
0
0
    $msg .= ": @args" if @args;
595
596
0
0
    die "$msg\n at $file line $line\n";
597}
598
599####################################################################
600# Helper functions for reading configuration
601####################################################################
602
603# $input is used as input buffer, it holds content of current input file.
604# Progressive matching is used. \G is used to match current position.
605sub skip_space_and_comment {
606
607    # Ignore trailing white space and comments.
608
112983
0
285320
    while ($input =~ m'\G[ \t]*(?:[#].*)?(?:\n|$)'gc) {
609
9655
22976
        $line++;
610    }
611
612    # Ignore leading white space.
613
112983
119016
    $input =~ m/\G[ \t]*/gc;
614
112983
93870
    return;
615}
616
617# Optimize use of CORE:regcomp. Build regex only once for each token.
618my %token2regex;
619
620# Check for a string and skip if available.
621sub check {
622
96427
0
75156
    my $token = shift;
623
96427
99103
    skip_space_and_comment;
624
96427
273837
    my $regex = $token2regex{$token} ||= qr/\G$token/;
625
96427
415506
    return $input =~ /$regex/gc;
626}
627
628# Skip a string.
629sub skip {
630
19078
0
16319
    my $token = shift;
631
19078
20448
    return(check $token or syntax_err("Expected '$token'"));
632}
633
634# Check, if an integer is available.
635sub check_int {
636
1617
0
1711
    skip_space_and_comment;
637
1617
2860
    if ($input =~ m/\G(\d+)/gc) {
638
1591
3221
        return $1;
639    }
640    else {
641
26
52
        return;
642    }
643}
644
645sub read_int {
646
1272
0
1420
    my $result = check_int();
647
1272
2088
    defined $result or syntax_err("Integer expected");
648
1272
2144
    return $result;
649}
650
651# Read IP address. Internally it is stored as an integer.
652sub check_ip {
653
2771
0
2935
    skip_space_and_comment;
654
2771
8082
    if ($input =~ m/\G(\d+)\.(\d+)\.(\d+)\.(\d+)/gc) {
655
2771
20983
        if ($1 > 255 or $2 > 255 or $3 > 255 or $4 > 255) {
656
0
0
            error_atline("Invalid IP address");
657        }
658
2771
8715
        return unpack 'N', pack 'C4', $1, $2, $3, $4;
659    }
660    else {
661
0
0
        return;
662    }
663}
664
665sub read_ip {
666
2771
0
3446
    my $result = check_ip();
667
2771
4509
    defined $result or syntax_err("IP address expected");
668
2771
3063
    return $result;
669}
670
671# Read IP address and prefix length.
672# x.x.x.x/n
673sub read_ip_prefix {
674
1232
0
2341
    my $ip = read_ip;
675
1232
1588
    skip('/');
676
1232
1746
    my $mask = prefix2mask(read_int());
677
1232
1926
    defined $mask or syntax_err('Invalid prefix');
678
1232
1567
    match_ip($ip, $ip, $mask) or error_atline("IP and mask don't match");
679
680    # Prevent further errors.
681
1232
1164
    $ip &= $mask;
682
1232
1941
    return $ip, $mask;
683}
684
685sub read_ip_prefix_pair {
686
77
0
90
    my ($ip, $mask) = read_ip_prefix();
687
77
130
    return [ $ip, $mask ];
688}
689
690sub gen_ip {
691
4500
0
3802
    my ($byte1, $byte2, $byte3, $byte4) = @_;
692
4500
9510
    return unpack 'N', pack('C4', $byte1, $byte2, $byte3, $byte4);
693}
694
695# Convert IP address from internal integer representation to
696# readable string.
697sub print_ip {
698
2866
0
2406
    my $ip = shift;
699
2866
7977
    return sprintf "%vd", pack 'N', $ip;
700}
701
702# Conversion from netmask to prefix and vice versa.
703{
704
705    # Initialize private variables of this block.
706    my %mask2prefix;
707    my %prefix2mask;
708    for my $prefix (0 .. 32) {
709        my $mask = 2**32 - 2**(32 - $prefix);
710        $mask2prefix{$mask}   = $prefix;
711        $prefix2mask{$prefix} = $mask;
712    }
713
714    # Convert a network mask to a prefix ranging from 0 to 32.
715    sub mask2prefix {
716
1752
0
1526
        my $mask = shift;
717
1752
2602
        return $mask2prefix{$mask};
718    }
719
720    sub prefix2mask {
721
3602
0
2871
        my $prefix = shift;
722
3602
5124
        return $prefix2mask{$prefix};
723    }
724}
725
726sub complement_32bit {
727
4555
0
3553
    my ($ip) = @_;
728
4555
5608
    return ~$ip & 0xffffffff;
729}
730
731# Check if $ip1 is located inside network $ip/$mask.
732sub match_ip {
733
3585
0
3712
    my ($ip1, $ip, $mask) = @_;
734
3585
8493
    return ($ip == ($ip1 & $mask));
735}
736
737sub read_identifier {
738
1337
0
1467
    skip_space_and_comment;
739
1337
2995
    if ($input =~ m/(\G[\w-]+)/gc) {
740
1337
2636
        return $1;
741    }
742    else {
743
0
0
        syntax_err("Identifier expected");
744    }
745}
746
747# Pattrern for attribute "visible": "*" or "name*".
748sub read_owner_pattern {
749
0
0
0
    skip_space_and_comment;
750
0
0
    if ($input =~ m/ ( \G [\w-]* [*] ) /gcx) {
751
0
0
        return $1;
752    }
753    else {
754
0
0
        syntax_err("Pattern '*' or 'name*' expected");
755    }
756}
757
758# Used for reading hardware name, model, admins, watchers.
759sub read_name {
760
1751
0
1969
    skip_space_and_comment;
761
1751
4035
    if ($input =~ m/(\G[^;,\s""'']+)/gc) {
762
1751
3528
        return $1;
763    }
764    else {
765
0
0
        syntax_err("String expected");
766    }
767}
768
769# Used for reading alias name or radius attributes.
770sub read_string {
771
35
0
43
    skip_space_and_comment;
772
35
66
    if ($input =~ m/\G([^;,""''\n]+)/gc) {
773
35
64
        return $1;
774    }
775    else {
776
0
0
        syntax_err("String expected");
777    }
778}
779
780# Object representing 'user'.
781# This is only 'active' while parsing src or dst of the rule of a service.
782my $user_object = { active => 0, refcount => 0, elements => undef };
783
784sub read_union {
785
728
0
707
    my ($delimiter) = @_;
786
728
564
    my @vals;
787
728
700
    my $count = $user_object->{refcount};
788
728
877
    push @vals, read_intersection();
789
728
1360
    my $has_user_ref   = $user_object->{refcount} > $count;
790
728
613
    my $user_ref_error = 0;
791
728
558
    while (1) {
792
745
875
        last if check $delimiter;
793
17
29
        my $comma_seen = check ',';
794
795        # Allow trailing comma.
796
17
33
        last if check $delimiter;
797
798
17
36
        $comma_seen or syntax_err("Comma expected in union of values");
799
17
25
        $count = $user_object->{refcount};
800
17
26
        push @vals, read_intersection();
801
17
73
        $user_ref_error ||=
802          $has_user_ref != ($user_object->{refcount} > $count);
803    }
804    $user_ref_error
805
728
1169
      and error_atline("The sub-expressions of union equally must\n",
806                       " either reference 'user' or must not reference 'user'");
807
728
1232
    return @vals;
808}
809
810# Check for xxx:xxx | router:xx@xx | network:xx/xx | interface:xx/xx
811sub check_typed_name {
812
5622
0
5871
    skip_space_and_comment;
813
5622
16418
    $input =~ m/ \G (\w+) : /gcx or return;
814
4062
6295
    my $type = $1;
815
4062
3086
    my ($name, $separator);
816
4062
10730
    if ($input =~ m' \G ( [\w-]+ (?: ( [@/] ) [\w-]+ )? ) 'gcx) {
817
4062
4723
        $name = $1;
818
4062
4206
        $separator = $2;
819    }
820    else {
821
0
0
        syntax_err("Invalid token");
822    }
823
824
4062
5729
    if ($separator) {
825
46
135
        if ($type eq 'router') {
826
6
12
            $separator eq '@' or syntax_err("Invalid token");
827        }
828        elsif ($type eq 'network' or $type eq 'interface') {
829
40
63
            $separator eq '/' or syntax_err("Invalid token");
830        }
831        else {
832
0
0
            syntax_err("Invalid token");
833        }
834    }
835
4062
11224
    return [ $type, $name ];
836}
837
838sub read_typed_name {
839
1727
0
1916
    return check_typed_name || syntax_err("Typed name expected");
840}
841
842{
843
844    # user@domain or @domain
845    my $domain_regex   = qr/(?:[\w-]+\.)+[\w-]+/;
846    my $user_regex     = qr/[\w-]+(?:\.[\w-]+)*/;
847    my $user_id_regex  = qr/$user_regex[@]$domain_regex/;
848    my $id_regex       = qr/$user_id_regex|[@]?$domain_regex/;
849    my $hostname_regex = qr/(?: id:$id_regex | [\w-]+ )/x;
850    my $network_regex  = qr/(?: [\w-]+ (?: \/ [\w-]+ )? )/x;
851
852# Check for xxx:xxx or xxx:[xxx:xxx, ...]
853# or interface:xxx.xxx
854# or interface:xxx.xxx.xxx
855# or interface:xxx.[xxx]
856# or interface:r@v. ...
857# or interface:....xxx/ppp...
858# or interface:[xxx:xxx, ...].[xxx]
859# or interface:[managed & xxx:xxx, ...].[xxx]
860# or host:[managed & xxx:xxx, ...]
861# or any:[ ip = n.n.n.n/len & xxx:xxx, ...]
862# or network:xxx/ppp
863# or host:id:user@domain.network
864# or host:id:[@]domain.network
865#
866    sub read_extended_name {
867
868
1259
0
1422
        if (check 'user') {
869
870            # Global variable for linking occurrences of 'user'.
871
322
609
            $user_object->{active}
872              or syntax_err("Unexpected reference to 'user'");
873
322
296
            $user_object->{refcount}++;
874
322
887
            return [ 'user', $user_object ];
875        }
876
937
3482
        $input =~ m/\G([\w-]+):/gc or syntax_err("Type expected");
877
937
1358
        my $type = $1;
878
937
1026
        my $interface = $type eq 'interface';
879
937
729
        my $name;
880        my $ext;
881
937
3600
        if ($input =~ m/ \G \[ /gcox) {
882
106
578
            if (($interface || $type eq 'host') && check('managed')) {
883
4
5
                $ext = 1;
884
4
5
                skip '&';
885            }
886            elsif ($type eq 'any' && check('ip')) {
887
44
61
                skip '=';
888
44
70
                $ext = read_ip_prefix_pair();
889
44
55
                skip '&';
890            }
891
106
200
            $name = [ read_union(']') ];
892        }
893        elsif ($type eq 'host') {
894
101
5057
            $input =~ m/ \G ( $hostname_regex ) /gcox
895              or syntax_err("Name or ID-name expected");
896
101
415
            $name = $1;
897        }
898        elsif ($type eq 'network') {
899
505
11239
            $input =~ m/ \G ( $network_regex ) /gcox
900              or syntax_err("Name or bridged name expected");
901
505
1165
            $name = $1;
902        }
903        elsif ($interface && $input =~ m/ \G ( [\w-]+ (?: \@ [\w-]+ ) ) /gcx
904            || $input =~ m/ \G ( [\w-]+ ) /gcx)
905        {
906
225
336
            $name = $1;
907        }
908        else {
909
0
0
            syntax_err("Identifier or '[' expected");
910        }
911
937
1517
        if ($interface) {
912
196
423
            $input =~ m/ \G \. /gcox or syntax_err("Expected '.'");
913
196
294
            if ($input =~ m/ \G \[ /gcox) {
914
31
44
                my $selector = read_identifier;
915
31
109
                $selector =~ /^(auto|all)$/ or syntax_err("Expected [auto|all]");
916
31
52
                $ext = [ $selector, $ext ];
917
31
43
                skip '\]';
918            }
919            else {
920
165
244
                $ext and syntax_err("Keyword 'managed' not allowed");
921
165
5973
                $input =~ m/ \G ( $network_regex ) /gcox
922                  or syntax_err("Name or bridged name expected");
923
165
336
                $ext = $1;
924
925                # ID of secondary interface.
926
165
341
                if ($input =~ m/ \G \. /gcox) {
927
16
23
                    $ext .= '.' . read_identifier;
928                }
929            }
930        }
931
937
3059
        return $ext ? [ $type, $name, $ext ] : [ $type, $name ];
932    }
933
934# user@domain
935    sub read_user_id {
936
9
0
14
        skip_space_and_comment;
937
9
377
        if ($input =~ m/\G($user_id_regex)/gco) {
938
9
20
            return $1;
939        }
940        else {
941
0
0
            syntax_err("Id expected ('user\@domain' or 'user')");
942        }
943    }
944
945# host:xxx or host:id:user@domain or host:id:[@]domain
946    sub check_hostname {
947
325
0
410
        skip_space_and_comment;
948
325
700
        if ($input =~ m/\G host:/gcx) {
949
201
13412
            if ($input =~ m/\G($hostname_regex)/gco) {
950
201
608
                return $1;
951            }
952            else {
953
0
0
                syntax_err('Hostname expected');
954            }
955        }
956        else {
957
124
236
            return;
958        }
959    }
960}
961
962sub read_complement {
963
1259
0
1405
    if (check '!') {
964
7
12
        return [ '!', read_extended_name() ];
965    }
966    else {
967
1252
1681
        return read_extended_name();
968    }
969}
970
971sub read_intersection {
972
1251
0
1492
    my @result = read_complement();
973
1251
1969
    while (check '&') {
974
8
16
        push @result, read_complement();
975    }
976
1251
1883
    if (@result == 1) {
977
1243
1816
        return $result[0];
978    }
979    else {
980
8
20
        return [ '&', \@result ];
981    }
982}
983
984# Setup standard time units with different names and plural forms.
985my %timeunits = (sec => 1, min => 60, hour => 3600, day => 86400,);
986$timeunits{second} = $timeunits{sec};
987$timeunits{minute} = $timeunits{min};
988for my $key (keys %timeunits) {
989    $timeunits{"${key}s"} = $timeunits{$key};
990}
991
992# Read time value in different units, return seconds.
993sub read_time_val {
994
40
0
49
    my $int    = read_int();
995
40
59
    my $unit   = read_identifier();
996
40
82
    my $factor = $timeunits{$unit} or syntax_err("Invalid time unit");
997
40
78
    return $int * $factor;
998}
999
1000sub add_description {
1001
3756
0
3403
    my ($obj) = @_;
1002
3756
4156
    check 'description' or return;
1003
2
4
    skip '=';
1004
1005    # Read up to end of line, but ignore ';' at EOL.
1006    # We must use '$' here to match EOL,
1007    # otherwise $line would be out of sync.
1008
2
22
    $input =~ m/\G[ \t]*(.*?)[ \t]*;?[ \t]*$/gcm;
1009
2
4
    if (store_description()) {
1010
0
0
        $obj->{description} = $1;
1011    }
1012
2
2
    return;
1013}
1014
1015# Check if one of the keywords 'permit' or 'deny' is available.
1016sub check_permit_deny {
1017
311
0
379
    skip_space_and_comment();
1018
311
798
    if ($input =~ m/\G(permit|deny)/gc) {
1019
311
972
        return $1;
1020    }
1021    else {
1022
0
0
        return;
1023    }
1024}
1025
1026sub check_nat_name {
1027
136
0
160
    skip_space_and_comment;
1028
136
420
    if ($input =~ m/\G nat:([\w-]+)/gcx) {
1029
136
367
        return $1;
1030    }
1031    else {
1032
0
0
        return;
1033    }
1034}
1035sub split_typed_name {
1036
181
0
212
    my ($name) = @_;
1037
1038    # Split at first colon; the name may contain further colons.
1039
181
595
    return split /[:]/, $name, 2;
1040}
1041
1042sub check_flag {
1043
18003
0
14602
    my $token = shift;
1044
18003
18570
    if (check $token) {
1045
237
375
        skip(';');
1046
237
468
        return 1;
1047    }
1048    else {
1049
17766
33187
        return;
1050    }
1051}
1052
1053sub check_assign {
1054
14291
0
13344
    my ($token, $fun) = @_;
1055
14291
14942
    if (check($token)) {
1056
2877
3660
        skip '=';
1057
2877
4352
        if (wantarray) {
1058
1155
1402
            my @val = &$fun;
1059
1155
1403
            skip(';');
1060
1155
3079
            return @val;
1061        }
1062        else {
1063
1722
1997
            my $val = &$fun;
1064
1722
2354
            skip(';');
1065
1722
4110
            return $val;
1066        }
1067    }
1068
11414
27539
    return;
1069}
1070
1071sub read_list {
1072
2652
0
2350
    my ($fun) = @_;
1073
2652
2063
    my @vals;
1074
2652
2037
    while (1) {
1075
2956
3446
        push @vals, &$fun;
1076
2956
3793
        last if check(';');
1077
331
445
        my $comma_seen = check ',';
1078
1079        # Allow trailing comma.
1080
331
466
        last if check(';');
1081
1082
304
510
        $comma_seen or syntax_err("Comma expected in list of values");
1083    }
1084
2652
7212
    return @vals;
1085}
1086
1087sub read_list_or_null {
1088
11
0
18
    my ($fun) = @_;
1089
11
14
    return () if check(';');
1090
11
21
    return read_list($fun);
1091}
1092
1093sub read_assign_list {
1094
311
0
695
    my ($token, $fun) = @_;
1095
311
377
    skip $token;
1096
311
441
    skip '=';
1097
311
475
    return read_list($fun);
1098}
1099
1100sub check_assign_list {
1101
11622
0
10987
    my ($token, $fun) = @_;
1102
11622
12372
    if (check $token) {
1103
2027
2536
        skip '=';
1104
2027
3033
        return &read_list($fun);
1105    }
1106
9595
24169
    return ();
1107}
1108
1109sub check_assign_pair {
1110
104
0
121
    my ($token, $delimiter, $fun) = @_;
1111
104
127
    if (check $token) {
1112
22
32
        skip '=';
1113
22
32
        my $v1 = &$fun;
1114
22
31
        skip $delimiter;
1115
22
26
        my $v2 = &$fun;
1116
22
33
        skip(';');
1117
22
60
        return $v1, $v2;
1118    }
1119
82
204
    return ();
1120}
1121
1122####################################################################
1123# Creation of typed structures
1124# Currently we don't use OO features;
1125# We use 'bless' only to give each structure a distinct type.
1126####################################################################
1127
1128# A hash, describing, which parts are read fom JSON.
1129# Possible keys:
1130# - watchers
1131my $from_json;
1132
1133# Create a new structure of given type;
1134# initialize it with key / value pairs.
1135sub new {
1136
8253
0
13026
    my ($type, @pairs) = @_;
1137
8253
13802
    my $self = {@pairs};
1138
8253
24129
    return bless $self, $type;
1139}
1140
1141sub add_attribute {
1142
6180
0
6494
    my ($obj, $key, $value) = @_;
1143
6180
10145
    defined $obj->{$key} and error_atline("Duplicate attribute '$key'");
1144
6180
7232
    $obj->{$key} = $value;
1145
6180
8365
    return;
1146}
1147
1148our %hosts;
1149
1150sub check_radius_attributes {
1151
1889
0
1857
    my $result = {};
1152
1889
2257
    check 'radius_attributes' or return;
1153
23
31
    skip '=';
1154
23
32
    skip '\{';
1155
23
24
    while (1) {
1156
55
61
        last if check '\}';
1157
32
44
        my $key = read_identifier();
1158
32
45
        my $val = check('=') ? read_string : undef;
1159
32
44
        skip ';';
1160
32
44
        add_attribute($result, $key => $val);
1161    }
1162
23
47
    return $result;
1163}
1164
1165sub check_routing {
1166
1696
0
2316
    my $protocol = check_assign('routing', \&read_identifier) or return;
1167
141
352
    my $routing = $routing_info{$protocol}
1168      or error_atline('Unknown routing protocol');
1169
141
253
    return $routing;
1170}
1171
1172sub check_managed {
1173
2716
0
2996
    check('managed') or return;
1174
473
458
    my $managed;
1175
473
589
    if (check ';') {
1176
416
455
        $managed = 'standard';
1177    }
1178    elsif (check '=') {
1179
57
88
        my $value = read_identifier;
1180
57
188
        if ($value =~ /^(?:secondary|standard|full|primary|
1181                           local|local_secondary|routing_only)$/x)
1182        {
1183
57
62
            $managed = $value;
1184        }
1185        else {
1186
0
0
            error_atline("Expected value:",
1187                         " secondary|standard|full|primary",
1188                         "|local|local_secondary|routing_only");
1189        }
1190
57
69
        check ';';
1191    }
1192    else {
1193
0
0
        syntax_err("Expected ';' or '='");
1194    }
1195
473
888
    return $managed;
1196}
1197
1198sub check_model {
1199
2217
0
3076
    my ($model, @attributes) = check_assign_list('model', \&read_name)
1200        or return;
1201
485
772
    my $info = $router_info{$model};
1202
485
934
    if (not $info) {
1203
1
2
        error_atline("Unknown router model");
1204
1205        # Prevent further errors.
1206
1
4
        return { name => $model };;
1207    }
1208
484
1027
    my $extension_info = $info->{extension} || {};
1209
1210
125
147
    my @ext_list = map {
1211
484
568
        my $ext = $extension_info->{$_};
1212
125
185
        $ext or error_atline("Unknown extension $_");
1213
125
453
        $ext ? %$ext : ();
1214    } @attributes;
1215
484
997
    if (@ext_list) {
1216
123
1051
        $info = { %$info, @ext_list };
1217
123
272
        delete $info->{extension};
1218
123
322
        $info->{name} = join(', ', $model, sort @attributes);
1219    }
1220
484
1049
    return $info;
1221}
1222
1223my @managed_routers;
1224my @router_fragments;
1225
1226# Managed host is stored internally as an interface.
1227# The interface gets an artificial router.
1228# Both, router and interface get name "host:xx".
1229sub host_as_interface {
1230
20
0
22
    my ($host) = @_;
1231
20
22
    my $name = $host->{name};
1232
20
25
    my $model = delete $host->{model};
1233
20
24
    my $hw_name = delete $host->{hardware};
1234
20
48
    if (!$model) {
1235
1
3
        err_msg("Missing 'model' for managed $host->{name}");
1236
1237        # Prevent further errors.
1238
1
2
        $model = $host->{model} = { name => 'unknown' };
1239    }
1240    elsif (!$model->{can_managed_host}) {
1241
0
0
        err_msg("Must not use model $model->{name} at managed $name");
1242    }
1243
20
33
    if (!$hw_name) {
1244
0
0
        err_msg("Missing 'hardware' for $name");
1245    }
1246
1247    # Use device_name with "host:.." prefix to prevent name clash with
1248    # real routers.
1249
20
27
    my $device_name =
1250        $host->{server_name} ? "host:$host->{server_name}" : $name;
1251
20
27
    my $router = new('Router', name => $name, device_name => $device_name);
1252
20
31
    $router->{managed} = delete $host->{managed};
1253
20
21
    $router->{model} = $model;
1254
20
35
    my $interface = new('Interface', %$host);
1255
20
22
    $interface->{router} = $router;
1256
20
43
    my $hardware = { name => $hw_name, interfaces => [ $interface ] };
1257
20
22
    $interface->{hardware} = $hardware;
1258
20
23
    $interface->{routing} = $routing_info{manual};
1259
20
19
    $interface->{is_managed_host} = 1;
1260
20
26
    $router->{interfaces} = [ $interface ];
1261
20
23
    $router->{hardware}   = [ $hardware ];
1262
1263    # Don't add to %routers
1264    # - Name lookup isn't needed.
1265    # - Linking with network isn't needed.
1266
20
20
    push @managed_routers, $router;
1267
20
81
    return $interface;
1268}
1269
1270sub read_host {
1271
201
0
246
    my ($name, $network_name) = @_;
1272
201
265
    my $host = new('Host');
1273
201
343
    $host->{private} = $private if $private;
1274
201
502
    if (my ($id) = ($name =~ /^host:id:(.*)$/)) {
1275
1276        # Make ID unique by appending name of enclosing network.
1277
26
44
        $name = "$name.$network_name";
1278
26
55
        $host->{id} = $id;
1279    }
1280
201
312
    $host->{name} = $name;
1281
201
261
    skip '=';
1282
201
293
    skip '\{';
1283
201
312
    add_description($host);
1284
201
208
    while (1) {
1285
483
585
        last if check '\}';
1286
282
511
        if (my $ip = check_assign 'ip', \&read_ip) {
1287
178
1345
            add_attribute($host, ip => $ip);
1288        }
1289        elsif (my ($ip1, $ip2) = check_assign_pair('range', '-', \&read_ip)) {
1290
22
36
            $ip1 <= $ip2 or error_atline("Invalid IP range");
1291
22
47
            add_attribute($host, range => [ $ip1, $ip2 ]);
1292        }
1293
1294        # Currently, only simple 'managed' attribute,
1295        # because 'secondary' and 'local' isn't supported by Linux.
1296        elsif (my $managed = check_managed()) {
1297
20
33
            $managed eq 'standard'
1298              or error_atline("Only 'managed=standard' is supported");
1299
20
28
            add_attribute($host, managed => $managed);
1300        }
1301        elsif (my $model = check_model()) {
1302
20
30
            $host->{model} and error_atline("Duplicate attribute 'model'");
1303
20
25
            add_attribute($host, model => $model);
1304        }
1305        elsif (my $hardware = check_assign('hardware', \&read_name)) {
1306
21
30
            add_attribute($host, hardware => $hardware);
1307        }
1308        elsif (my $server_name = check_assign('server_name', \&read_name)) {
1309
2
3
            add_attribute($host, server_name => $server_name);
1310        }            
1311        elsif (my $owner = check_assign 'owner', \&read_identifier) {
1312
7
12
            add_attribute($host, owner => $owner);
1313        }
1314        elsif (my $radius_attributes = check_radius_attributes) {
1315
9
15
            add_attribute($host, radius_attributes => $radius_attributes);
1316        }
1317        elsif (my $pair = check_typed_name) {
1318
3
5
            my ($type, $name) = @$pair;
1319
3
6
            if ($type eq 'nat') {
1320
3
5
                skip '=';
1321
3
62
                skip '\{';
1322
3
6
                skip 'ip';
1323
3
6
                skip '=';
1324
3
5
                my $nat_ip = read_ip;
1325
3
7
                skip ';';
1326
3
6
                skip '\}';
1327
3
10
                $host->{nat}->{$name}
1328                  and error_atline("Duplicate NAT definition");
1329
3
9
                $host->{nat}->{$name} = $nat_ip;
1330            }
1331            else {
1332
0
0
                syntax_err("Expected NAT definition");
1333            }
1334        }
1335        else {
1336
0
0
            syntax_err("Unexpected attribute");
1337        }
1338    }
1339
201
934
    $host->{ip} xor $host->{range}
1340      or error_atline("Exactly one of attributes 'ip' and 'range' is needed");
1341
1342
201
344
    if ($host->{managed}) {
1343
20
71
        my %ok = ( name => 1, ip => 1, nat => 1, file => 1, private => 1,
1344                   managed => 1, model => 1, hardware => 1, server_name => 1);
1345
20
76
        for my $key (sort keys %$host) {
1346
101
160
            next if $ok{$key};
1347
1
5
            error_atline("Managed $host->{name} must not have attribute '$key'");
1348        }
1349
20
45
        $host->{ip} ||= 'short';
1350
20
28
        return host_as_interface($host);
1351    }
1352
181
284
    if ($host->{id}) {
1353
26
65
        $host->{radius_attributes} ||= {};
1354    }
1355    else {
1356
155
278
        $host->{radius_attributes}
1357          and error_atline("Attribute 'radius_attributes' is not allowed",
1358                           " for $name");
1359    }
1360
181
303
    if ($host->{nat}) {
1361
2
4
        if ($host->{range}) {
1362
1363            # Before changing this,
1364            # - look at print_pix_static,
1365            # - add consistency tests in convert_hosts.
1366
0
0
            error_atline("No NAT supported for host with 'range'");
1367        }
1368    }
1369
181
242
    return $host;
1370}
1371
1372sub read_nat {
1373
136
0
151
    my $name = shift;
1374
1375    # Currently this needs not to be blessed.
1376
136
214
    my $nat = { name => $name };
1377
136
435
    (my $nat_tag = $name) =~ s/^nat://;
1378
136
211
    skip '=';
1379
136
192
    skip '\{';
1380
136
129
    while (1) {
1381
312
382
        last if check '\}';
1382
176
293
        if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
1383
90
134
            add_attribute($nat, ip => $ip);
1384
90
109
            add_attribute($nat, mask => $mask);
1385        }
1386        elsif (check_flag 'hidden') {
1387
37
60
            $nat->{hidden} = 1;
1388        }
1389        elsif (check_flag 'identity') {
1390
9
15
            $nat->{identity} = 1;
1391        }
1392        elsif (check_flag 'dynamic') {
1393
1394            # $nat_tag is used later to look up static translation
1395            # of hosts inside a dynamically translated network.
1396
38
79
            $nat->{dynamic} = $nat_tag;
1397        }
1398        elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1399
2
3
            add_attribute($nat, subnet_of => $pair);
1400        }
1401        else {
1402
0
0
            syntax_err("Expected some valid NAT attribute");
1403        }
1404    }
1405
136
305
    if ($nat->{hidden}) {
1406
37
78
        for my $key (keys %$nat) {
1407
74
148
69
278
            next if grep { $key eq $_ } qw( name hidden );
1408
0
0
            error_atline("Hidden NAT must not use attribute $key");
1409        }
1410
1411        # This simplifies error checks for overlapping addresses.
1412
37
60
        $nat->{dynamic} = $nat_tag;
1413    }
1414    elsif ($nat->{identity}) {
1415
9
21
        for my $key (keys %$nat) {
1416
18
36
21
69
            next if grep { $key eq $_ } qw( name identity );
1417
0
0
            error_atline("Identity NAT must not use attribute $key");
1418        }
1419
9
17
        $nat->{dynamic} = $nat_tag;
1420    }
1421    else {
1422
90
170
        defined($nat->{ip}) or error_atline('Missing IP address');
1423    }
1424
136
168
    return $nat;
1425}
1426
1427our %networks;
1428
1429sub read_network {
1430
1053
0
988
    my $name = shift;
1431
1432    # Network name without prefix "network:" is needed to build
1433    # name of ID-hosts.
1434
1053
3212
    (my $net_name = $name) =~ s/^network://;
1435
1053
1640
    my $network = new('Network', name => $name);
1436
1053
1618
    $network->{private} = $private if $private;
1437
1053
1980
    if ($net_name =~ m,^(.*)/,) {
1438
14
29
        $network->{bridged} = $1;
1439    }
1440
1053
1313
    skip '=';
1441
1053
1484
    skip '\{';
1442
1053
1623
    add_description($network);
1443
1053
956
    while (1) {
1444
2532
2970
        last if check '\}';
1445
1479
2629
        if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
1446
1042
1441
            add_attribute($network, ip => $ip);
1447
1042
1160
            add_attribute($network, mask => $mask);
1448        }
1449        elsif (check_flag 'unnumbered') {
1450
11
23
            defined $network->{ip} and error_atline("Duplicate IP address");
1451
11
21
            $network->{ip} = 'unnumbered';
1452        }
1453        elsif (check_flag 'has_subnets') {
1454
1455            # Duplicate use of this flag doesn't matter.
1456
36
66
            $network->{has_subnets} = 1;
1457        }
1458        elsif (check_flag 'crosslink') {
1459
1460            # Duplicate use of this flag doesn't matter.
1461
10
18
            $network->{crosslink} = 1;
1462        }
1463        elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1464
30
54
            add_attribute($network, subnet_of => $pair);
1465        }
1466        elsif (my $owner = check_assign 'owner', \&read_identifier) {
1467
19
35
            add_attribute($network, owner => $owner);
1468        }
1469        elsif (my $radius_attributes = check_radius_attributes) {
1470
6
10
            add_attribute($network, radius_attributes => $radius_attributes);
1471        }
1472        elsif (my $host_name = check_hostname()) {
1473
201
497
            my $host = read_host("host:$host_name", $net_name);
1474
201
274
            $host->{network} = $network;
1475
201
301
            if (is_host($host)) {
1476
181
181
158
310
                push @{ $network->{hosts} }, $host;
1477
181
300
                $host_name = (split_typed_name($host->{name}))[1];
1478            }
1479
1480            # Managed host is stored as interface internally.
1481            elsif (is_interface($host)) {
1482
20
20
18
30
                push @{ $network->{interfaces} }, $host;
1483
20
32
                check_interface_ip($host, $network);
1484
1485                # For use in expand_group.
1486
20
20
13
33
                push @{ $network->{managed_hosts} }, $host;
1487            }
1488            else {
1489
0
0
                internal_err;
1490            }
1491
201
488
            if (my $other = $hosts{$host_name}) {
1492
0
0
                my $where = $current_file;
1493
0
0
                my $other_net = $other->{network};
1494
0
0
                if ($other_net ne $network) {
1495
0
0
                    $where .= " $other_net->{file}";
1496                }
1497
0
0
                err_msg("Duplicate definition of host:$host_name in $where");
1498            }
1499
201
1118
            $hosts{$host_name} = $host;
1500        }
1501        elsif (my $nat_tag = check_nat_name()) {
1502
124
258
            my $nat = read_nat("nat:$nat_tag");
1503
124
320
            ($network->{nat} && $network->{nat}->{$nat_tag})
1504              and error_atline("Duplicate NAT definition");
1505
1506
124
282
            $nat->{name} .= "($name)";
1507
124
336
            $network->{nat}->{$nat_tag} = $nat;
1508        }
1509        else {
1510
0
0
            syntax_err("Expected some valid attribute");
1511        }
1512    }
1513
1514    # Network needs at least IP and mask to be defined.
1515
1053
1422
    my $ip = $network->{ip};
1516
1517    # Use 'defined' here because IP may have value '0'.
1518
1053
1565
    defined $ip or syntax_err("Missing network IP");
1519
1520
1053
2228
    if ($ip eq 'unnumbered') {
1521
11
31
        my %ok = (ip => 1, name => 1, crosslink => 1, private => 1);
1522
1523        # Unnumbered network must not have any other attributes.
1524
11
25
        for my $key (keys %$network) {
1525
22
50
            next if $ok{$key};
1526
0
0
            error_atline("Unnumbered $network->{name} must not have ",
1527                           ($key eq 'hosts') ? "host definition"
1528                         : ($key eq 'nat')   ? "nat definition"
1529                         :                     "attribute '$key'");
1530        }
1531    }
1532    elsif ($network->{bridged}) {
1533
14
46
        my %ok = (ip => 1, mask => 1, bridged => 1, name => 1, private => 1,
1534                  nat => 1, owner => 1, crosslink => 1);
1535
1536        # Bridged network must not have any other attributes.
1537
14
30
        for my $key (keys %$network) {
1538
57
98
            next if $ok{$key};
1539
0
0
            error_atline(
1540              "Bridged $network->{name} must not have ",
1541                ($key eq 'hosts') ? "host definition (not implemented)"
1542                                  : "attribute '$key'");
1543        }
1544
14
37
        if (my $hash = $network->{nat}) {
1545
0
0
            for my $nat_tag (sort keys %$hash) {
1546
0
0
                $hash->{$nat_tag}->{identity} and next;
1547
0
0
                delete $hash->{$nat_tag};
1548
0
0
                err_msg("Only identity NAT allowed for bridged $network->{name}");
1549
0
0
                last;
1550            }
1551        }
1552    }
1553    else {
1554
1028
1041
        my $mask = $network->{mask};
1555
1028
1028
837
2015
        for my $host (@{ $network->{hosts} }) {
1556
1557            # Check compatibility of host IP and network IP/mask.
1558
181
323
            if (my $host_ip = $host->{ip}) {
1559
160
248
                if (not(match_ip($host_ip, $ip, $mask))) {
1560
0
0
                    error_atline("$host->{name}'s IP doesn't match".
1561                                 " network IP/mask");
1562                }
1563            }
1564            elsif ($host->{range}) {
1565
21
21
19
28
                my ($ip1, $ip2) = @{ $host->{range} };
1566
21
33
                if (
1567                    not(    match_ip($ip1, $ip, $mask)
1568                        and match_ip($ip2, $ip, $mask))
1569                  )
1570                {
1571
0
0
                    error_atline("$host->{name}'s IP range doesn't match",
1572                                 " network IP/mask");
1573                }
1574            }
1575            else {
1576
0
0
                internal_err();
1577            }
1578
1579            # Compatibility of host and network NAT will be checked later,
1580            # after inherited NAT definitions have been processed.
1581        }
1582
1028
1028
878
2455
        if (@{ $network->{hosts} } and $network->{crosslink}) {
1583
1
2
            error_atline("Crosslink network must not have host definitions");
1584        }
1585
1028
1618
        if ($network->{nat}) {
1586
1587            # Check NAT definitions.
1588
95
95
86
198
            for my $nat (values %{ $network->{nat} }) {
1589
124
251
                next if $nat->{dynamic};
1590
52
123
                $nat->{mask} == $mask
1591                    or error_atline("Mask for non dynamic $nat->{name}",
1592                                    " must be equal to network mask");
1593            }
1594        }
1595
1596        # Check and mark networks with ID-hosts.
1597
1028
181
1028
807
364
1673
        if (my $id_hosts_count = grep { $_->{id} } @{ $network->{hosts} }) {
1598
1599            # If one host has ID, all hosts must have ID.
1600
13
13
13
24
            @{ $network->{hosts} } == $id_hosts_count
1601              or error_atline("All hosts must have ID in $name");
1602
1603            # Mark network.
1604
13
17
            $network->{has_id_hosts} = 1;
1605
13
32
            $network->{radius_attributes} ||= {};
1606        }
1607        else {
1608
1015
1860
            $network->{radius_attributes}
1609              and error_atline("Attribute 'radius_attributes' is",
1610                               " not allowed for $name");
1611        }
1612    }
1613
1053
1330
    return $network;
1614}
1615
1616our %interfaces;
1617my @virtual_interfaces;
1618my $global_active_pathrestriction = new(
1619    'Pathrestriction',
1620    name        => 'global_pathrestriction',
1621    active_path => 1
1622);
1623
1624# Tunnel networks which are already attached to tunnel interfaces
1625# at spoke devices. Key is crypto name, not crypto object.
1626my %crypto2spokes;
1627
1628# Real interfaces at crypto hub, where tunnels are attached.
1629# Key is crypto name, not crypto object.
1630my %crypto2hubs;
1631
1632sub read_interface {
1633
1485
0
1367
    my ($name) = @_;
1634
1485
1841
    my $interface = new('Interface', name => $name);
1635
1636    # Short form of interface definition.
1637
1485
1815
    if (not check '=') {
1638
188
253
        skip ';';
1639
188
284
        $interface->{ip} = 'short';
1640
188
314
        return $interface;
1641    }
1642
1643
1297
1503
    my @secondary_interfaces = ();
1644
1297
985
    my $virtual;
1645
1297
1594
    skip '\{';
1646
1297
1907
    add_description($interface);
1647
1297
1162
    while (1) {
1648
3889
4508
        last if check '\}';
1649
2592
4154
        if (my @ip = check_assign_list 'ip', \&read_ip) {
1650
1226
1788
            add_attribute($interface, ip => shift(@ip));
1651
1652            # Build interface objects for secondary IP addresses.
1653            # These objects are named interface:router.name.2, ...
1654
1226
1057
            my $counter = 2;
1655
1226
2182
            for my $ip (@ip) {
1656
5
17
                push @secondary_interfaces,
1657                  new('Interface', name => "$name.$counter", ip => $ip);
1658
5
13
                $counter++;
1659            }
1660        }
1661        elsif (check_flag 'unnumbered') {
1662
13
20
            add_attribute($interface, ip => 'unnumbered');
1663        }
1664        elsif (check_flag 'negotiated') {
1665
3
5
            add_attribute($interface, ip => 'negotiated');
1666        }
1667        elsif (check_flag 'loopback') {
1668
27
54
            $interface->{loopback} = 1;
1669        }
1670        elsif (check_flag 'vip') {
1671
5
10
            $interface->{vip} = 1;
1672        }
1673        elsif (check_flag 'no_in_acl') {
1674
7
14
            $interface->{no_in_acl} = 1;
1675        }
1676        elsif (check_flag 'dhcp_server') {
1677
1
3
            $interface->{dhcp_server} = 1;
1678        }
1679
1680        # Needed for the implicitly defined network of 'loopback'.
1681        elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1682
4
6
            add_attribute($interface, subnet_of => $pair);
1683        }
1684        elsif (my @pairs = check_assign_list 'hub', \&read_typed_name) {
1685
18
22
            for my $pair (@pairs) {
1686
21
26
                my ($type, $name2) = @$pair;
1687
21
37
                $type eq 'crypto' or error_atline("Expected type 'crypto'");
1688
21
21
21
101
                push @{ $interface->{hub} }, "$type:$name2";
1689            }
1690        }
1691        elsif ($pair = check_assign 'spoke', \&read_typed_name) {
1692
25
34
            my ($type, $name2) = @$pair;
1693
25
43
            $type eq 'crypto' or error_atline("Expected type crypto");
1694
25
64
            add_attribute($interface, spoke => "$type:$name2");
1695        }
1696        elsif (my $id = check_assign 'id', \&read_user_id) {
1697
9
13
            add_attribute($interface, id => $id);
1698        }
1699        elsif (defined(my $level = check_assign 'security_level', \&read_int)) {
1700
0
0
            $level > 100
1701              and error_atline("Maximum value for attribute security_level",
1702                               " is 100");
1703
0
0
            add_attribute($interface, security_level => $level);
1704        }
1705        elsif ($pair = check_typed_name) {
1706
11
17
            my ($type, $name2) = @$pair;
1707
11
26
            if ($type eq 'nat') {
1708
2
4
                skip '=';
1709
2
4
                skip '\{';
1710
2
3
                skip 'ip';
1711
2
4
                skip '=';
1712
2
4
                my $nat_ip = read_ip;
1713
2
3
                skip ';';
1714
2
5
                skip '\}';
1715
2
6
                $interface->{nat}->{$name2}
1716                  and error_atline("Duplicate NAT definition");
1717
2
7
                $interface->{nat}->{$name2} = $nat_ip;
1718            }
1719            elsif ($type eq 'secondary') {
1720
1721                # Build new interface for secondary IP addresses.
1722
9
26
                my $secondary = new('Interface', name => "$name.$name2");
1723
9
15
                skip '=';
1724
9
12
                skip '\{';
1725
9
10
                while (1) {
1726
18
23
                    last if check '\}';
1727
9
24
                    if (my $ip = check_assign 'ip', \&read_ip) {
1728
9
13
                        add_attribute($secondary, ip => $ip);
1729                    }
1730                    else {
1731
0
0
                        syntax_err("Expected attribute IP");
1732                    }
1733                }
1734
9
19
                if ($secondary->{ip}) {
1735
9
26
                    push @secondary_interfaces, $secondary;
1736                }
1737                else {
1738
0
0
                    error_atline("Missing IP address");
1739                }
1740            }
1741            else {
1742
0
0
                syntax_err("Expected nat or secondary interface definition");
1743            }
1744        }
1745        elsif (check 'virtual') {
1746
72
130
            $virtual and error_atline("Duplicate virtual interface");
1747
1748            # Read attributes of redundancy protocol (VRRP/HSRP).
1749
72
190
            $virtual = new(
1750                'Interface',
1751                name      => "$name.virtual",
1752                redundant => 1
1753            );
1754
72
102
            skip '=';
1755
72
103
            skip '\{';
1756
72
68
            while (1) {
1757
158
183
                last if check '\}';
1758
86
135
                if (my $ip = check_assign 'ip', \&read_ip) {
1759
72
100
                    add_attribute($virtual, ip => $ip);
1760                }
1761                elsif (my $type = check_assign 'type', \&read_identifier) {
1762
14
28
                    $xxrp_info{$type}
1763                      or error_atline("unknown redundancy protocol");
1764
14
18
                    add_attribute($virtual, redundancy_type => $type);
1765                }
1766                elsif (my $id = check_assign 'id', \&read_identifier) {
1767
0
0
                    $id =~ /^\d+$/
1768                      or error_atline("Redundancy ID must be numeric");
1769
0
0
                    $id < 256 or error_atline("Redundancy ID must be < 256");
1770
0
0
                    add_attribute($virtual, redundancy_id => $id);
1771                }
1772                else {
1773
0
0
                    syntax_err("Expected valid attribute for virtual IP");
1774                }
1775            }
1776
72
149
            $virtual->{ip} or error_atline("Missing virtual IP");
1777
72
203
            ($virtual->{redundancy_id} && !$virtual->{redundancy_type}) and
1778                syntax_err("Redundancy ID is given without redundancy protocol");
1779        }
1780        elsif (my @tags = check_assign_list 'bind_nat', \&read_identifier) {
1781
108
201
            $interface->{bind_nat} and error_atline("Duplicate NAT binding");
1782
108
193
            $interface->{bind_nat} = [ unique sort @tags ];
1783        }
1784        elsif (my $hardware = check_assign 'hardware', \&read_name) {
1785
1044
1411
            add_attribute($interface, hardware => $hardware);
1786        }         
1787        elsif (my $owner = check_assign 'owner', \&read_identifier) {
1788
3
4
            add_attribute($interface, owner => $owner);
1789        }
1790        elsif (my $routing = check_routing()) {
1791
8
13
            add_attribute($interface, routing => $routing);
1792        }
1793        elsif (@pairs = check_assign_list 'reroute_permit', \&read_typed_name) {
1794
2
2
3
13
            if (grep { $_->[0] ne 'network' || ref $_->[1] } @pairs) {
1795
0
0
                error_atline "Must only use network names in 'reroute_permit'";
1796
0
0
                @pairs = ();
1797            }
1798
2
4
            add_attribute($interface, reroute_permit => \@pairs);
1799        }
1800        elsif (check_flag 'disabled') {
1801
3
9
            $interface->{disabled} = 1;
1802        }
1803        elsif (check_flag 'no_check') {
1804
3
9
            $interface->{no_check} = 1;
1805        }
1806        else {
1807
0
0
            syntax_err('Expected some valid attribute');
1808        }
1809    }
1810
1811    # Interface at bridged network
1812    # - without IP is interface of bridge,
1813    # - with IP is interface of router.
1814
1297
2509
    if ($name =~ m,/,) {
1815
24
62
        $interface->{ip} ||= 'bridged';
1816    }
1817
1818    # Swap virtual interface and main interface
1819    # or take virtual interface as main interface if no main IP available.
1820    # Subsequent code becomes simpler if virtual interface is main interface.
1821
1297
1609
    if ($virtual) {
1822
72
136
        if (my $ip = $interface->{ip}) {
1823
64
160
            if ($ip =~ /^(unnumbered|negotiated|short|bridged)$/) {
1824
0
0
                error_atline("No virtual IP supported for $ip interface");
1825            }
1826
1827            # Move main IP to secondary.
1828
64
98
            my $secondary =
1829              new('Interface', name => $interface->{name}, ip => $ip);
1830
64
57
            push @secondary_interfaces, $secondary;
1831
1832            # But we need the original main interface
1833            # when handling auto interfaces.
1834
64
84
            $interface->{orig_main} = $secondary;
1835        }
1836
72
72
169
103
        @{$interface}{qw(name ip redundant redundancy_type redundancy_id)} =
1837
72
69
          @{$virtual}{qw(name ip redundant redundancy_type redundancy_id)};
1838
72
98
        push @virtual_interfaces, $interface;
1839    }
1840    else {
1841
1225
2218
        $interface->{ip} ||= 'short';
1842    }
1843
1297
2035
    if ($interface->{nat}) {
1844
2
6
        if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) {
1845
0
0
            error_atline("No NAT supported for $interface->{ip} interface");
1846        }
1847    }
1848
1297
1898
    if ($interface->{vip}) {
1849
5
9
        $interface->{loopback} = 1;
1850
5
10
        $interface->{hardware} and
1851            error_atline("'vip' interface must not have attribute 'hardware'");
1852
5
5
        $interface->{hardware} = 'VIP';
1853    }
1854
1297
2214
    if ($interface->{owner} && !$interface->{vip}) {
1855
0
0
        error_atline("Must use attribute 'owner' only at 'vip' interface");
1856
0
0
        delete $interface->{owner};
1857    }
1858
1297
2549
    if ($interface->{loopback}) {
1859
32
128
        my %copy = %$interface;
1860
1861        # Only these attributes are valid.
1862        delete @copy{
1863
32
104
            qw(name ip nat bind_nat hardware loopback subnet_of
1864              owner redundant redundancy_type redundancy_id vip)
1865          };
1866
32
58
        if (keys %copy) {
1867
0
0
0
0
            my $attr = join ", ", map { "'$_'" } keys %copy;
1868
0
0
            my $type = $interface->{vip} ? "'vip'" : 'loopback';
1869
0
0
            error_atline("Invalid attributes $attr for $type interface");
1870        }
1871
32
104
        if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) {
1872
0
0
            my $type = $interface->{vip} ? "'vip'" : 'Loopback';
1873
0
0
            error_atline("$type interface must not be $interface->{ip}");
1874
0
0
            $interface->{disabled} = 1;
1875        }
1876    }
1877    elsif ($interface->{subnet_of}) {
1878
0
0
        error_atline("Attribute 'subnet_of' is only valid",
1879                     " for loopback interface");
1880    }
1881
1297
2332
    if ($interface->{ip} eq 'bridged') {
1882
14
33
        my %ok = (ip => 1, hardware => 1, name => 1, bind_nat => 1);
1883
14
42
29
87
        if (my @extra = grep { !$ok{$_} } keys %$interface) {
1884
0
0
0
0
            my $attr = join ", ", map { "'$_'" } @extra;
1885
0
0
            error_atline("Invalid attributes $attr for bridged interface");
1886        }
1887    }
1888
1297
1683
    if (my $crypto = $interface->{spoke}) {
1889        @secondary_interfaces
1890
25
41
          and error_atline("Interface with attribute 'spoke'",
1891                           " must not have secondary interfaces");
1892
25
37
        $interface->{hub}
1893          and error_atline("Interface with attribute 'spoke'",
1894                           " must not have attribute 'hub'");
1895    }
1896    else {
1897
1272
1937
        $interface->{id}
1898          and error_atline("Attribute 'id' is only valid for 'spoke' interface");
1899    }
1900
1297
1897
    if (my $crypto_list = $interface->{hub}) {
1901
18
44
        if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) {
1902
0
0
            error_atline("Crypto hub must not be $interface->{ip} interface");
1903        }
1904
18
27
        for my $crypto (@$crypto_list) {
1905
21
21
17
62
            push @{ $crypto2hubs{$crypto} }, $interface;
1906        }
1907    }
1908
1297
1945
    if (@secondary_interfaces) {
1909
74
173
        if ($interface->{ip} =~ /^(unnumbered|negotiated|short|bridged)$/) {
1910
0
0
            error_atline("\u$interface->{ip} interface must not have",
1911                         " secondary IP address");
1912
0
0
            @secondary_interfaces = ();
1913        }
1914    }
1915
1297
1664
    for my $secondary (@secondary_interfaces) {
1916
78
91
        $secondary->{main_interface} = $interface;
1917
78
77
        for my $key (qw(hardware bind_nat routing disabled)) {
1918
312
679
            $secondary->{$key} = $interface->{$key} if $interface->{$key};
1919        }
1920    }
1921
1297
2327
    return $interface, @secondary_interfaces;
1922}
1923
1924# PIX firewalls have a security level associated with each interface.
1925# Use attribute 'security_level' or
1926# try to derive the level from the interface name.
1927sub set_pix_interface_level {
1928
258
0
264
    my ($router) = @_;
1929
258
258
208
373
    for my $hardware (@{ $router->{hardware} }) {
1930
551
569
        my $hwname = $hardware->{name};
1931
551
413
        my $level;
1932
551
455
        if (
1933
556
556
4078
879
            my @levels = grep { defined($_) }
1934
551
678
                map { $_->{security_level} } @{ $hardware->{interfaces} }
1935          )
1936        {
1937
0
0
            if (@levels >= 2 && !equal(@levels)) {
1938
0
0
                err_msg "Must not use different values",
1939                  " for attribute 'security_level'\n",
1940                  " at $router->{name}, hardware $hwname: ", join(',', @levels);
1941            }
1942            else {
1943
0
0
                $level = $levels[0];
1944            }
1945        }
1946        elsif ($hwname =~ 'inside') {
1947
66
68
            $level = 100;
1948        }
1949        elsif ($hwname =~ 'outside') {
1950
64
62
            $level = 0;
1951        }
1952
1953        # It is not necessary the find the exact level; what we need to know
1954        # is the relation of the security levels to each other.
1955        elsif (($level) = ($hwname =~ /(\d+)$/) and $level <= 100) {
1956        }
1957        else {
1958
19
19
            $level = 50;
1959        }
1960
551
1190
        $hardware->{level} = $level;
1961    }
1962
258
326
    return;
1963}
1964
1965my $bind_nat0 = [];
1966
1967our %routers;
1968
1969sub read_router {
1970
650
0
628
    my $name = shift;
1971
1972    # Extract
1973    # - router name without prefix "router:", needed to build interface name
1974    # - optional vrf name
1975
650
3062
    my ($rname, $device_name, $vrf) =
1976      $name =~ /^ router : ( (.*?) (?: \@ (.*) )? ) $/x;
1977
650
1049
    my $router = new('Router', name => $name, device_name => $device_name);
1978
650
1083
    if (defined $vrf) {
1979
1980        # VRF value "0" would be interpreted as false by perl.
1981
6
9
        $vrf or error_atline("Must not use '$vrf' as VRF value");
1982
6
11
        $router->{vrf} = $vrf;
1983    }
1984
650
809
    skip '=';
1985
650
906
    skip '\{';
1986
650
982
    add_description($router);
1987
650
612
    while (1) {
1988
3284
4035
        last if check '\}';
1989
2634
3594
        if (my $managed = check_managed()) {
1990
453
919
            $router->{managed}
1991              and error_atline("Redefining 'managed' attribute");
1992
453
688
            $router->{managed} = $managed;
1993        }
1994        elsif (my @filter_only = check_assign_list('filter_only',
1995                                                   \&read_ip_prefix_pair))
1996        {
1997
26
39
            add_attribute($router, filter_only => \@filter_only);
1998        }
1999        elsif (my $model = check_model()) {
2000
465
638
            add_attribute($router, model => $model);
2001        }
2002        elsif (check_flag 'no_group_code') {
2003
0
0
            $router->{no_group_code} = 1;
2004        }
2005        elsif (check_flag 'no_crypto_filter') {
2006
8
17
            $router->{no_crypto_filter} = 1;
2007        }
2008        elsif (check_flag 'no_protect_self') {
2009
1
2
            $router->{no_protect_self} = 1;
2010        }
2011        elsif (check_flag 'strict_secondary') {
2012
0
0
            $router->{strict_secondary} = 1;
2013        }
2014        elsif (check_flag 'log_deny') {
2015
1
3
            $router->{log_deny} = 1;
2016        }
2017        elsif (my $routing = check_routing()) {
2018
133
195
            add_attribute($router, routing => $routing);
2019        }
2020        elsif (my $owner = check_assign 'owner', \&read_identifier) {
2021
1
2
            add_attribute($router, owner => $owner);
2022        }
2023        elsif (my $radius_attributes = check_radius_attributes) {
2024
8
13
            add_attribute($router, radius_attributes => $radius_attributes);
2025        }
2026        elsif (my $pair = check_assign('policy_distribution_point',
2027                                       \&read_typed_name))
2028        {
2029
8
13
            add_attribute($router, policy_distribution_point => $pair);
2030        }
2031        elsif (my @list = check_assign_list('general_permit',
2032                                            \&read_typed_name_or_simple_protocol))
2033        {
2034
11
20
            add_attribute($router, general_permit => \@list);
2035        }
2036        else {
2037
1519
1906
            my $pair = read_typed_name;
2038
1519
1988
            my ($type, $name2) = @$pair;
2039
1519
3147
            if ($type eq 'log') {
2040
34
76
                defined($router->{log}->{$name2})
2041                        and error_atline("Duplicate 'log' definition");
2042
34
45
                my $modifier = check('=') ? read_identifier() : 0;
2043
34
62
                $router->{log}->{$name2} = $modifier;
2044
34
46
                skip(';');
2045
34
85
                next;
2046            }
2047            elsif ($type ne 'interface') {
2048
0
0
                syntax_err("Expected interface or log definition");
2049            }
2050
2051            # Derive interface name from router name.
2052
1485
2518
            my $iname = "$rname.$name2";
2053
1485
3487
            for my $interface (read_interface "interface:$iname") {
2054
1563
1563
1208
2286
                push @{ $router->{interfaces} }, $interface;
2055
1563
4639
                ($iname = $interface->{name}) =~ s/interface://;
2056
1563
3197
                if ($interfaces{$iname}) {
2057
3
8
                    error_atline("Redefining $interface->{name}");
2058                }
2059
2060                # Assign interface to global hash of interfaces.
2061
1563
2288
                $interfaces{$iname} = $interface;
2062
2063                # Link interface with router object.
2064
1563
1601
                $interface->{router} = $router;
2065
2066                # Link interface with network name (will be resolved later).
2067
1563
1846
                $interface->{network} = $name2;
2068
2069                # Set private attribute of interface.
2070
1563
5774
                $interface->{private} = $private if $private;
2071            }
2072        }
2073    }
2074
2075
650
867
    my $model = $router->{model};
2076
2077    # Owner at vip interfaces is allowed for managed and unmanaged
2078    # devices and hence must be checked for both.
2079    {
2080
650
650
529
494
        my $error;
2081
650
650
530
944
        for my $interface (@{ $router->{interfaces} }) {
2082
1563
3171
            if ($interface->{vip} && !($model && $model->{has_vip})) {
2083
2
2
                $error = 1;
2084
2085                # Prevent further errors.
2086
2
3
                delete $interface->{vip};
2087
2
4
                delete $interface->{owner};
2088            }
2089        }
2090
650
1145
        if ($error) {
2091
2
12
9
15
            my $valid = join(', ', grep({ $router_info{$_}->{has_vip} }
2092                                        sort keys %router_info));
2093
2
8
            err_msg("Must not use attribute 'vip' at $name\n",
2094                    " 'vip' is only allowed for model $valid");
2095        }
2096    }
2097
2098
650
1102
    if (my $managed = $router->{managed}) {
2099
453
423
        my $all_routing = $router->{routing};
2100
2101
453
723
        unless ($model) {
2102
0
0
            err_msg("Missing 'model' for managed $name");
2103
2104            # Prevent further errors.
2105
0
0
            $router->{model} = { name => 'unknown' };
2106        }
2107
2108        # Router is semi_managed if only routes are generated.
2109
453
747
        if ($managed eq 'routing_only') {
2110
6
7
            $router->{semi_managed} = 1;
2111
6
8
            $router->{routing_only} = 1;
2112
6
11
            delete $router->{managed};
2113        }
2114
2115
453
868
        $router->{vrf}
2116          and not $model->{can_vrf}
2117          and err_msg("Must not use VRF at $name",
2118            " of model $model->{name}");
2119
2120        # Create objects representing hardware interfaces.
2121        # All logical interfaces using the same hardware are linked
2122        # to the same hardware object.
2123
453
360
        my %hardware;
2124
453
453
361
605
        for my $interface (@{ $router->{interfaces} }) {
2125
2126            # Managed router must not have short interface.
2127
1079
1633
            if ($interface->{ip} eq 'short') {
2128
1
4
                err_msg
2129                    "Short definition of $interface->{name} not allowed";
2130            }
2131
2132
1079
1104
            my $hw_name = $interface->{hardware};
2133
2134            # Interface of managed router needs to have a hardware
2135            # name.
2136
1079
1460
            if (!$hw_name) {
2137
2138                # Prevent duplicate error message.
2139
1
3
                if ($interface->{ip} ne 'short') {
2140
1
3
                    err_msg("Missing 'hardware' for $interface->{name}");
2141                }
2142
2143                # Prevent further errors.
2144
1
2
                $hw_name = 'unknown';
2145            }
2146
2147
1079
792
            my $hardware;
2148
1079
1645
            if ($hardware = $hardware{$hw_name}) {
2149
2150                # All logical interfaces of one hardware interface
2151                # need to use the same NAT binding,
2152                # because NAT operates on hardware, not on logic.
2153
65
322
                aref_eq(
2154                    $interface->{bind_nat} || $bind_nat0,
2155                    $hardware->{bind_nat}  || $bind_nat0
2156                  )
2157                  or err_msg "All logical interfaces of $hw_name\n",
2158                  " at $name must use identical NAT binding";
2159            }
2160            else {
2161
1014
1891
                $hardware = { name => $hw_name, loopback => 1 };
2162
1014
1366
                $hardware{$hw_name} = $hardware;
2163
1014
1014
772
1322
                push @{ $router->{hardware} }, $hardware;
2164
1014
1652
                if (my $nat = $interface->{bind_nat}) {
2165
67
76
                    $hardware->{bind_nat} = $nat;
2166                }
2167
2168                # Hardware name 'VIP' is used internally at loadbalancers.
2169
1014
1817
                    $hw_name eq 'VIP'
2170                and $model->{has_vip}
2171                and not $interface->{vip}
2172                and err_msg("Must not use hardware 'VIP' at",
2173                            " $interface->{name}");
2174            }
2175
1079
1054
            $interface->{hardware} = $hardware;
2176
2177            # Hardware keeps attribute {loopback} only if all
2178            # interfaces have attribute {loopback}.
2179
1079
1561
            if (!$interface->{loopback}) {
2180
1054
1226
                delete $hardware->{loopback};
2181            }
2182
2183            # Remember, which logical interfaces are bound
2184            # to which hardware.
2185
1079
1079
805
1742
            push @{ $hardware->{interfaces} }, $interface;
2186
2187            # Don't allow 'routing=manual' at single interface, because
2188            # approve would remove manual routes otherwise.
2189            # Approve only leaves routes unchanged, if Netspoc generates
2190            # no routes at all.
2191
1079
1651
            if ((my $routing = $interface->{routing})) {
2192
8
16
                $routing->{name} eq 'manual' and
2193                    warn_msg("'routing=manual' must only be applied",
2194                             " to router, not to $interface->{name}");
2195            }
2196
2197            # Interface inherits routing attribute from router.
2198
1079
1427
            if ($all_routing) {
2199
331
883
                $interface->{routing} ||= $all_routing;
2200            }
2201
1079
3320
            if ((my $routing = $interface->{routing}) &&
2202                $interface->{ip} eq 'unnumbered')
2203            {
2204
0
0
                my $rname = $routing->{name};
2205
0
0
                $rname =~ /^(?:manual|dynamic)$/ or
2206                    error_atline("Routing $rname not supported",
2207                                 " for unnumbered interface");
2208            }
2209        }
2210    }
2211
650
1090
    if (my $managed = $router->{managed}) {
2212
447
855
        if ($managed =~ /^local/) {
2213
27
49
            $router->{filter_only} or
2214                err_msg("Missing attribute 'filter_only' for $name");
2215
27
44
            $model->{has_io_acl} and
2216                err_msg("Must not use 'managed = $managed' at $name",
2217                        " of model $model->{name}");
2218        }
2219
447
871
        $router->{log_deny}
2220          and not $model->{can_log_deny}
2221          and err_msg("Must not use attribute 'log_deny' at $name",
2222            " of model $model->{name}");
2223
2224
447
707
        if (my $hash = $router->{log}) {
2225
19
29
            if (my $log_modifiers = $model->{log_modifiers}) {
2226
19
53
                for my $name2 (sort keys %$hash) {
2227
2228                    # 0: simple unmodified 'log' statement.
2229
34
65
                    my $modifier = $hash->{$name2} or next;
2230
2231
31
67
                    $log_modifiers->{$modifier} and next;
2232
2233
3
12
                    my $valid = join('|', sort keys %$log_modifiers);
2234
3
11
                    my $what = "'log:$name2 = $modifier' at $name" .
2235                               " of model $model->{name}";
2236
3
6
                    if ($valid) {
2237
2
7
                        err_msg("Invalid $what\n Expected one of: $valid");
2238                    }
2239                    else {
2240
1
4
                        err_msg("Unexpected $what\n Use 'log:$name2;' only.");
2241                    }
2242                }
2243            }
2244            else {
2245
0
0
                my ($name2) = sort keys %$hash;
2246
0
0
                err_msg("Must not use attribute 'log:$name2' at $name",
2247                        " of model $model->{name}");
2248            }
2249        }                    
2250
2251
447
861
        $router->{no_protect_self}
2252          and not $model->{need_protect}
2253          and err_msg("Must not use attribute 'no_protect_self' at $name",
2254            " of model $model->{name}");
2255
447
727
        if ($model->{need_protect}) {
2256
165
332
            $router->{need_protect} = !delete $router->{no_protect_self};
2257        }
2258
2259
447
826
        $router->{strict_secondary}
2260          and $managed !~ /secondary$/
2261          and err_msg("Must not use attribute 'strict_secondary' at $name.\n",
2262                      " Only valid with 'managed = secondary|local_secondary'");
2263
2264        # Detailed interface processing for managed routers.
2265
447
447
369
624
        for my $interface (@{ $router->{interfaces} }) {
2266
1067
1813
            if (defined $interface->{security_level}
2267                && !$model->{has_interface_level})
2268            {
2269
0
0
                warn_msg("Ignoring attribute 'security_level'",
2270                    " at $interface->{name}");
2271            }
2272
1067
3121
            if ($interface->{hub} or $interface->{spoke}) {
2273
21
37
                $model->{crypto}
2274                  or err_msg "Crypto not supported for $name",
2275                  " of model $model->{name}";
2276            }
2277
1067
2121
            if ($interface->{no_check}
2278                and not($interface->{hub} and $model->{do_auth}))
2279            {
2280
0
0
                delete $interface->{no_check};
2281
0
0
                warn_msg("Ignoring attribute 'no_check' at $interface->{name}");
2282            }
2283        }
2284
2285        # Collect bridged interfaces of this device and check
2286        # existence of corresponding layer3 device.
2287
447
442
        my %layer3_seen;
2288
447
447
388
551
        for my $interface (@{ $router->{interfaces} }) {
2289
1067
1945
            next if not $interface->{ip} eq 'bridged';
2290
14
68
            (my $layer3_name = $interface->{name}) =~ s/^interface:(.*)\/.*/$1/;
2291
14
15
            my $layer3_intf;
2292
14
33
            if (exists $layer3_seen{$layer3_name}) {
2293
7
8
                $layer3_intf = $layer3_seen{$layer3_name};
2294            }
2295            elsif ($layer3_intf = $interfaces{$layer3_name}) {
2296
2297                # Mark layer3 interface as loopback interface internally,
2298                # because we only have layer2 networks and no layer3 network.
2299
7
9
                $layer3_intf->{loopback} = 1;
2300
2301                # Mark layer3 interface as such to prevent warning in
2302                # check_subnets.
2303
7
7
                $layer3_intf->{is_layer3} = 1;
2304
2305
7
14
                if ($model->{class} eq 'ASA') {
2306
7
16
                    $layer3_intf->{hardware}->{name} eq 'device'
2307                      or
2308                      err_msg("Layer3 $interface->{name} must use 'hardware'",
2309                        " named 'device' for model 'ASA'");
2310                }
2311
7
23
                if (my ($no_ip) = $layer3_intf->{ip} =~
2312                    /^(unnumbered|negotiated|short|bridged)$/)
2313                {
2314
0
0
                    err_msg(
2315                        "Layer3 $layer3_intf->{name}",
2316                        " must not be $no_ip"
2317                    );
2318
2319                    # Prevent further errors.
2320
0
0
                    $layer3_intf->{disabled} = 1;
2321
0
0
                    $layer3_intf = undef;
2322                }
2323            }
2324            else {
2325
0
0
                err_msg("Must define interface:$layer3_name for corresponding",
2326                        " bridge interfaces");
2327            }
2328
2329            # Link bridged interface to corresponding layer3 interface.
2330            # Used in path_auto_interfaces.
2331
14
16
            $interface->{layer3_interface} = $layer3_intf;
2332
14
24
            $layer3_seen{$layer3_name} = $layer3_intf;
2333        }
2334
2335        # Delete secondary interface of layer3 interface.
2336        # This prevents irritating error messages later.
2337
447
823
        if (keys %layer3_seen) {
2338
7
6
            my $changed;
2339
7
7
7
12
            for my $interface (@{ $router->{interfaces} }) {
2340
21
36
                my $main = $interface->{main_interface} or next;
2341
0
0
                if ($main->{is_layer3}) {
2342
0
0
                    err_msg("Layer3 $main->{name} must not have",
2343                            " secondary $interface->{name}");
2344
0
0
                    $interface = undef;
2345
0
0
                    $changed = 1;
2346                }
2347            }
2348
7
0
0
13
0
0
            $router->{interfaces} = [ grep { $_ } @{ $router->{interfaces} } ]
2349                if $changed;
2350        }
2351
447
738
        if ($model->{has_interface_level}) {
2352
258
379
            set_pix_interface_level($router);
2353        }
2354
447
817
        if ($managed =~ /^local/) {
2355
27
54
27
21
89
35
            grep { $_->{bind_nat} } @{ $router->{interfaces} }
2356              and err_msg "Attribute 'bind_nat' is not allowed",
2357              " at interface of $name with 'managed = $managed'";
2358        }
2359
447
639
        if ($model->{do_auth}) {
2360
2361
8
14
8
7
26
13
            grep { $_->{hub} } @{ $router->{interfaces} }
2362              or err_msg "Attribute 'hub' needs to be defined",
2363              "  at an interface of $name of model $model->{name}";
2364
2365            # Don't support NAT for VPN, otherwise code generation for VPN
2366            # devices will become more difficult.
2367
8
14
8
4
23
10
            grep { $_->{bind_nat} } @{ $router->{interfaces} }
2368              and err_msg "Attribute 'bind_nat' is not allowed",
2369              " at interface of $name of model $model->{name}";
2370
2371
8
15
            $router->{radius_attributes} ||= {};
2372        }
2373        else {
2374
439
732
            $router->{radius_attributes}
2375              and err_msg "Attribute 'radius_attributes' is not allowed",
2376              " for $name";
2377        }
2378
447
757
        if ($model->{no_crypto_filter}) {
2379
256
514
            $router->{no_crypto_filter} = 1;
2380        }
2381    }
2382
2383    # Unmanaged device.
2384    else {
2385
203
174
        my $bridged;
2386
203
392
        if (delete $router->{owner}) {
2387
0
0
            warn_msg("Ignoring attribute 'owner' at unmanaged $name");
2388        }
2389
203
203
173
270
        for my $interface (@{ $router->{interfaces} }) {
2390
496
689
            if ($interface->{hub}) {
2391
0
0
                error_atline("Interface with attribute 'hub' must only be",
2392                             " used at managed device");
2393            }
2394
496
712
            if (delete $interface->{reroute_permit}) {
2395
0
0
                warn_msg("Ignoring attribute 'reroute_permit'",
2396                         " at unmanaged $interface->{name}");
2397            }
2398
496
900
            if ($interface->{ip} eq 'bridged') {
2399
0
0
                $bridged = 1;
2400            }
2401        }
2402
2403        # Unmanaged bridge would complicate generation of static routes.
2404
203
351
        if ($bridged) {
2405
0
0
            error_atline("Bridged interfaces must only be used",
2406                         " at managed device");
2407        }
2408    }
2409
2410
650
532
    my @move_locked;
2411
2412
650
650
528
838
    for my $interface (@{ $router->{interfaces} }) {
2413
2414        # Automatically create a network for loopback interface.
2415
1588
2960
        if ($interface->{loopback}) {
2416
39
31
            my $name;
2417            my $net_name;
2418
2419            # Special handling needed for virtual loopback interfaces.
2420            # The created network needs to be shared among a group of
2421            # interfaces.
2422
39
57
            if ($interface->{redundant}) {
2423
2424                # Shared virtual loopback network gets name
2425                # 'virtual:netname'. Don't use standard name to prevent
2426                # network from getting referenced from rules.
2427
4
7
                $net_name = "virtual:$interface->{network}";
2428
4
5
                $name     = "network:$net_name";
2429            }
2430            else {
2431
2432                # Single loopback network needs not to get an unique name.
2433                # Take an invalid name 'router.loopback' to prevent name
2434                # clashes with real networks or other loopback networks.
2435
35
40
                $name = $interface->{name};
2436
35
130
                ($net_name = $name) =~ s/^interface://;
2437            }
2438
39
90
            if (not $networks{$net_name}) {
2439
37
101
                my $network = new(
2440                    'Network',
2441                    name => $name,
2442                    ip   => $interface->{ip},
2443                    mask => 0xffffffff,
2444
2445                    # Mark as automatically created.
2446                    loopback  => 1,
2447                    subnet_of => delete $interface->{subnet_of},
2448                    is_layer3 => $interface->{is_layer3},
2449                );
2450
37
77
                if (my $private = $interface->{private}) {
2451
0
0
                    $network->{private} = $private;
2452                }
2453
37
56
                $networks{$net_name} = $network;
2454            }
2455
39
50
            $interface->{network} = $net_name;
2456        }
2457
2458        # Generate tunnel interface.
2459        elsif (my $crypto = $interface->{spoke}) {
2460
25
225
            my $net_name    = "tunnel:$rname";
2461
25
40
            my $iname       = "$rname.$net_name";
2462
25
64
            my $tunnel_intf = new(
2463                'Interface',
2464                name           => "interface:$iname",
2465                ip             => 'tunnel',
2466                router         => $router,
2467                network        => $net_name,
2468                real_interface => $interface
2469            );
2470
25
36
            for my $key (qw(hardware routing private bind_nat id)) {
2471
125
193
                if ($interface->{$key}) {
2472
14
27
                    $tunnel_intf->{$key} = $interface->{$key};
2473                }
2474            }
2475
25
57
            if ($interfaces{$iname}) {
2476
0
0
                error_atline("Redefining $tunnel_intf->{name}");
2477            }
2478
25
39
            $interfaces{$iname} = $tunnel_intf;
2479
25
25
18
34
            push @{ $router->{interfaces} }, $tunnel_intf;
2480
2481            # Create tunnel network.
2482
25
51
            my $tunnel_net = new(
2483                'Network',
2484                name => "network:$net_name",
2485                ip   => 'tunnel'
2486            );
2487
25
44
            if (my $private = $interface->{private}) {
2488
0
0
                $tunnel_net->{private} = $private;
2489            }
2490
25
40
            $networks{$net_name} = $tunnel_net;
2491
2492            # Tunnel network will later be attached to crypto hub.
2493
25
25
18
47
            push @{ $crypto2spokes{$crypto} }, $tunnel_net;
2494        }
2495
2496
1588
5687
        if (($interface->{spoke} || $interface->{hub}) &&
2497            !$interface->{no_check})
2498        {
2499
40
61
            push @move_locked, $interface;
2500        }
2501    }
2502
2503
650
1128
    move_locked_interfaces(\@move_locked) if @move_locked;
2504
2505
650
1015
    return $router;
2506}
2507
2508# No traffic must traverse crypto or secondary interface.
2509# Hence split router into separate instances, one instance for each
2510# crypto/secondary interface.
2511# Splitted routers are tied by identical attribute {device_name}.
2512sub move_locked_interfaces {
2513
39
0
37
    my ($interfaces) = @_;
2514
39
45
    for my $interface (@$interfaces) {
2515
40
35
        my $orig_router = $interface->{router};
2516
40
39
        my $name = $orig_router->{name};
2517
40
127
        my $new_router = new('Router',
2518                             %$orig_router,
2519                             orig_router => $orig_router,
2520                             interfaces => [ $interface ]);
2521
40
56
        $interface->{router} = $new_router;
2522
40
35
        push @router_fragments, $new_router;
2523
2524        # Don't check fragment for reachability.
2525
40
45
        delete $new_router->{policy_distribution_point};
2526
2527        # Remove interface from old router.
2528        # Retain copy of original interfaces.
2529
40
36
        my $interfaces = $orig_router->{interfaces};
2530
40
138
        $orig_router->{orig_interfaces} ||= [ @$interfaces ];
2531
40
60
        aref_delete($interfaces, $interface);
2532
2533
40
441
        if ($orig_router->{managed}) {
2534
18
20
            my $hardware = $interface->{hardware};
2535
18
25
            $new_router->{hardware} = [ $hardware ];
2536
18
22
            my $hw_list = $orig_router->{hardware};
2537
2538            # Retain copy of original hardware.
2539
18
30
            $orig_router->{orig_hardware} = [ @$hw_list ];
2540
18
24
            aref_delete($hw_list, $hardware);
2541
18
18
15
41
            1 == @{ $hardware->{interfaces} } or
2542                err_msg("Crypto $interface->{name} must not share hardware",
2543                        " with other interfaces");
2544
18
46
            if (my $hash = $orig_router->{radius_attributes}) {
2545
2546                # Copy hash, because it is changed per device later.
2547
6
25
                $new_router->{radius_attributes} = { %$hash };
2548            }
2549        }        
2550    }
2551
39
43
    return;
2552}
2553
2554our %aggregates;
2555
2556sub read_aggregate {
2557
52
0
65
    my $name = shift;
2558
52
92
    my $aggregate = new('Network', name => $name, is_aggregate => 1);
2559
52
106
    $aggregate->{private} = $private if $private;
2560
52
74
    skip '=';
2561
52
84
    skip '\{';
2562
52
83
    add_description($aggregate);
2563
52
53
    while (1) {
2564
145
176
        last if check '\}';
2565
93
175
        if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
2566
23
36
            add_attribute($aggregate, ip => $ip);
2567
23
29
            add_attribute($aggregate, mask => $mask);
2568        }
2569        elsif (my $owner = check_assign 'owner', \&read_identifier) {
2570
10
22
            add_attribute($aggregate, owner => $owner);
2571        }
2572        elsif (my $link = check_assign 'link', \&read_typed_name) {
2573
52
89
            add_attribute($aggregate, link => $link);
2574        }
2575        elsif (check_flag 'has_unenforceable') {
2576
2
8
            $aggregate->{has_unenforceable} = 1;
2577        }
2578        elsif (my $nat_name = check_nat_name()) {
2579
6
15
            my $nat = read_nat("nat:$nat_name");
2580
6
12
            $nat->{dynamic} or error_atline("$nat->{name} must be dynamic");
2581
6
14
            $aggregate->{nat}->{$nat_name}
2582              and error_atline("Duplicate NAT definition");
2583
6
13
            $aggregate->{nat}->{$nat_name} = $nat;
2584        }
2585        else {
2586
0
0
            syntax_err("Expected some valid attribute");
2587        }
2588    }
2589
52
132
    $aggregate->{link} or err_msg("Attribute 'link' must be defined for $name");
2590
52
66
    my $ip   = $aggregate->{ip};
2591
52
49
    my $mask = $aggregate->{mask};
2592
52
85
    if ($ip) {
2593
21
59
        for my $key (keys %$aggregate) {
2594
107
749
96
942
            next if grep({ $key eq $_ }
2595                         qw( name ip mask link is_aggregate private nat));
2596
0
0
            error_atline("Must not use attribute $key if mask is set");
2597        }
2598    }
2599    else  {
2600
31
50
        $aggregate->{ip} = $aggregate->{mask} = 0;
2601    }
2602
52
76
    return $aggregate;
2603}
2604
2605sub check_router_attributes {
2606
13
0
15
    my ($parent) = @_;
2607
2608    # Add name for error messages.
2609
13
35
    my $result = { name => "router_attributes of $parent" };
2610
13
18
    check 'router_attributes' or return;
2611
7
10
    skip '=';
2612
7
9
    skip '\{';
2613
7
8
    while (1) {
2614
14
19
        last if check '\}';
2615
7
14
        if (my $owner = check_assign 'owner', \&read_identifier) {
2616
1
2
            add_attribute($result, owner => $owner);
2617        }
2618        elsif (my $pair = check_assign('policy_distribution_point',
2619                                       \&read_typed_name))
2620        {
2621
2
3
            add_attribute($result, policy_distribution_point => $pair);
2622        }
2623        elsif (my @list = check_assign_list('general_permit',
2624                                            \&read_typed_name_or_simple_protocol))
2625        {
2626
4
6
            add_attribute($result, general_permit => \@list);
2627        }
2628        else {
2629
0
0
            syntax_err("Unexpected attribute");
2630        }
2631    }
2632
7
16
    return $result;
2633}
2634
2635our %areas;
2636
2637sub read_area {
2638
66
0
71
    my $name = shift;
2639
66
111
    my $area = new('Area', name => $name);
2640
66
93
    skip '=';
2641
66
159
    skip '\{';
2642
66
112
    add_description($area);
2643
66
67
    while (1) {
2644
176
213
        last if check '\}';
2645
110
212
        if (my @elements = check_assign_list('border', \&read_intersection)) {
2646
40
44
49
239
            if (grep { $_->[0] ne 'interface' || ref $_->[1] } @elements) {
2647
0
0
                error_atline "Must only use interface names in border";
2648
0
0
                @elements = ();
2649            }
2650
40
63
            add_attribute($area, border => \@elements);
2651        }
2652        elsif (@elements =
2653            check_assign_list('inclusive_border', \&read_intersection))
2654        {
2655
12
18
17
146
            if (grep { $_->[0] ne 'interface' || ref $_->[1] } @elements) {
2656
0
0
                error_atline "Must only use interface names in border";
2657
0
0
                @elements = ();
2658            }
2659
12
23
            add_attribute($area, inclusive_border => \@elements);
2660        }
2661        elsif (check_flag 'auto_border') {
2662
2
4
            $area->{auto_border} = 1;
2663        }
2664        elsif (my $pair = check_assign 'anchor', \&read_typed_name) {
2665
17
86
            if ($pair->[0] ne 'network' || ref $pair->[1]) {
2666
0
0
                error_atline "Must only use network name in 'anchor'";
2667
0
0
                $pair = undef;
2668            }
2669
17
37
            add_attribute($area, anchor => $pair);
2670        }
2671        elsif (my $owner = check_assign 'owner', \&read_identifier) {
2672
26
41
            add_attribute($area, owner => $owner);
2673        }
2674        elsif (my $router_attributes = check_router_attributes($name)) {
2675
7
11
            add_attribute($area, router_attributes => $router_attributes);
2676        }
2677        elsif (my $nat_name = check_nat_name()) {
2678
6
13
            my $nat = read_nat("nat:$nat_name");
2679
6
13
            $nat->{dynamic} or error_atline("$nat->{name} must be dynamic");
2680
6
15
            $area->{nat}->{$nat_name}
2681              and error_atline("Duplicate NAT definition");
2682
6
14
            $area->{nat}->{$nat_name} = $nat;
2683        }
2684        else {
2685
0
0
            syntax_err("Expected some valid attribute");
2686        }
2687    }
2688
66
364
    (($area->{border} || $area->{inclusive_border}) && $area->{anchor})
2689      and err_msg("Attribute 'anchor' must not be defined together with",
2690                  " 'border' or 'inclusive_border' for $name");
2691
66
251
    ($area->{anchor} || $area->{border} || $area->{inclusive_border})
2692      or err_msg("At least one of attributes 'border', 'inclusive_border'",
2693                 " or 'anchor' must be defined for $name");
2694
66
82
    return $area;
2695}
2696
2697our %groups;
2698
2699sub read_group {
2700
9
0
12
    my $name = shift;
2701
9
18
    skip '=';
2702
9
19
    my $group = new('Group', name => $name);
2703
9
21
    $group->{private} = $private if $private;
2704
9
16
    add_description($group);
2705
9
20
    my @elements = read_list_or_null \&read_intersection;
2706
9
373
    $group->{elements} = \@elements;
2707
9
15
    return $group;
2708}
2709
2710our %protocolgroups;
2711
2712sub read_protocolgroup {
2713
2
0
3
    my $name = shift;
2714
2
2
    skip '=';
2715
2
5
    my @pairs = read_list_or_null \&read_typed_name_or_simple_protocol;
2716
2
4
    return new('Protocolgroup', name => $name, elements => \@pairs);
2717}
2718
2719sub read_port_range {
2720
286
0
337
    if (defined(my $port1 = check_int)) {
2721
267
504
        error_atline("Too large port number $port1") if $port1 > 65535;
2722
267
391
        error_atline("Invalid port number '0'") if $port1 == 0;
2723
267
341
        if (check '-') {
2724
21
29
            if (defined(my $port2 = check_int)) {
2725
21
42
                error_atline("Too large port number $port2") if $port2 > 65535;
2726
21
36
                error_atline("Invalid port number '0'") if $port2 == 0;
2727
21
34
                error_atline("Invalid port range $port1-$port2")
2728                  if $port1 > $port2;
2729
21
46
                if ($port1 == 1 && $port2 == 65535) {
2730
3
5
                    return $aref_tcp_any;
2731                }
2732                else {
2733
18
43
                    return [ $port1, $port2 ];
2734                }
2735            }
2736            else {
2737
0
0
                syntax_err("Missing second port in port range");
2738            }
2739        }
2740        else {
2741
246
558
            return [ $port1, $port1 ];
2742        }
2743    }
2744    else {
2745
19
27
        return $aref_tcp_any;
2746    }
2747}
2748
2749sub read_port_ranges {
2750
278
0
275
    my ($prt) = @_;
2751
278
369
    my $range = read_port_range;
2752
278
415
    if (check ':') {
2753
8
24
        if ($range ne $aref_tcp_any) {
2754
7
10
            $prt->{src_range} = $range;
2755        }
2756
8
11
        $prt->{dst_range} = read_port_range;
2757    }
2758    else {
2759
270
576
        $prt->{dst_range} = $range;
2760    }
2761
278
351
    return;
2762}
2763
2764sub read_icmp_type_code {
2765
37
0
42
    my ($prt) = @_;
2766
37
48
    if (defined(my $type = check_int)) {
2767
30
63
        error_atline("Too large ICMP type $type") if $type > 255;
2768
30
42
        if (check '/') {
2769
0
0
            if (defined(my $code = check_int)) {
2770
0
0
                error_atline("Too large ICMP code $code") if $code > 255;
2771
0
0
                $prt->{type} = $type;
2772
0
0
                $prt->{code} = $code;
2773            }
2774            else {
2775
0
0
                syntax_err("Expected ICMP code");
2776            }
2777        }
2778        else {
2779
30
49
            $prt->{type} = $type;
2780
30
158
            if ($type == 0 || $type == 3 || $type == 11) {
2781
12
22
                $prt->{flags}->{stateless_icmp} = 1;
2782            }
2783        }
2784    }
2785    else {
2786
2787        # No type and code given.
2788    }
2789
37
48
    return;
2790}
2791
2792sub read_proto_nr {
2793
1
0
1
    my ($prt) = @_;
2794
1
2
    if (defined(my $nr = check_int)) {
2795
1
2
        error_atline("Too large protocol number $nr") if $nr > 255;
2796
1
3
        error_atline("Invalid protocol number '0'")   if $nr == 0;
2797
1
4
        if ($nr == 1) {
2798
0
0
            $prt->{proto} = 'icmp';
2799
2800            # No ICMP type and code given.
2801        }
2802        elsif ($nr == 4) {
2803
0
0
            $prt->{proto} = 'tcp';
2804
0
0
            $prt->{dst_range} = $aref_tcp_any;
2805        }
2806        elsif ($nr == 17) {
2807
0
0
            $prt->{proto} = 'udp';
2808
0
0
            $prt->{dst_range} = $aref_tcp_any;
2809        }
2810        else {
2811
1
2
            $prt->{proto} = $nr;
2812        }
2813    }
2814    else {
2815
0
0
        syntax_err("Expected protocol number");
2816    }
2817
1
2
    return;
2818}
2819
2820sub gen_protocol_name {
2821
317
0
284
    my ($protocol) = @_;
2822
317
351
    my $proto      = $protocol->{proto};
2823
317
284
    my $name       = $proto;
2824
2825
317
914
    if ($proto eq 'ip') {
2826    }
2827    elsif ($proto eq 'tcp' or $proto eq 'udp') {
2828        my $port_name = sub {
2829
262
393
            my ($v1, $v2) = @_;
2830
262
451
            if ($v1 == $v2) {
2831
228
371
                return ($v1);
2832            }
2833            elsif ($v1 == 1 and $v2 == 65535) {
2834
19
30
                return ('');
2835            }
2836            else {
2837
15
36
                return ("$v1-$v2");
2838            }
2839
262
818
        };
2840
262
293
        my $src_range = $protocol->{src_range};
2841
262
606
        my $src_port = $src_range && $port_name->(@$src_range);
2842
262
262
246
480
        my $dst_port = $port_name->(@{ $protocol->{dst_range} });
2843
262
249
        my $port;
2844
262
393
        $port = "$src_port:" if $src_port;
2845
262
742
        $port .= "$dst_port" if $dst_port;
2846
262
1167
        $name .= " $port"    if $port;
2847    }
2848    elsif ($proto eq 'icmp') {
2849
31
66
        if (defined(my $type = $protocol->{type})) {
2850
24
39
            if (defined(my $code = $protocol->{code})) {
2851
0
0
                $name = "$proto $type/$code";
2852            }
2853            else {
2854
24
45
                $name = "$proto $type";
2855            }
2856        }
2857    }
2858    else {
2859
1
2
        $name = "proto $proto";
2860    }
2861
317
456
    return $name;
2862}
2863
2864our %protocols;
2865
2866sub cache_anonymous_protocol {
2867
317
0
329
    my ($protocol) = @_;
2868
317
403
    my $name = gen_protocol_name($protocol);
2869
317
614
    if (my $cached = $protocols{$name}) {
2870
25
36
        return $cached;
2871    }
2872    else {
2873
292
356
        $protocol->{name}    = $name;
2874
292
314
        $protocol->{is_used} = 1;
2875
292
407
        $protocols{$name}    = $protocol;
2876
292
387
        return $protocol;
2877    }
2878}
2879
2880sub read_simple_protocol {
2881
345
0
334
    my $name     = shift;
2882
345
398
    my $protocol = {};
2883
345
618
    my $proto = read_identifier();
2884
345
857
    if ($proto eq 'ip') {
2885
29
47
        $protocol->{proto} = 'ip';
2886    }
2887    elsif ($proto eq 'tcp') {
2888
264
401
        $protocol->{proto} = 'tcp';
2889
264
399
        read_port_ranges($protocol);
2890    }
2891    elsif ($proto eq 'udp') {
2892
14
25
        $protocol->{proto} = 'udp';
2893
14
19
        read_port_ranges $protocol;
2894    }
2895    elsif ($proto eq 'icmp') {
2896
37
64
        $protocol->{proto} = 'icmp';
2897
37
59
        read_icmp_type_code $protocol;
2898    }
2899    elsif ($proto eq 'proto') {
2900
1
3
        read_proto_nr $protocol;
2901    }
2902    else {
2903
0
0
        error_atline("Unknown protocol '$proto'");
2904
2905        # Prevent further errors.
2906
0
0
        $protocol->{proto} = 'ip';
2907    }
2908
345
447
    if ($name) {
2909
28
43
        $protocol->{name} = $name;
2910    }
2911    else {
2912
317
430
        $protocol = cache_anonymous_protocol($protocol);
2913    }
2914
345
824
    return $protocol;
2915}
2916
2917sub check_protocol_flags {
2918
28
0
32
    my ($protocol) = @_;
2919
28
40
    while (check ',') {
2920
7
11
        my $flag = read_identifier;
2921
7
34
        if ($flag =~ /^(src|dst)_(net|any)$/) {
2922
3
13
            $protocol->{flags}->{$1}->{$2} = 1;
2923        }
2924        elsif ($flag =~
2925            /^(?:stateless|reversed|oneway|overlaps|no_check_supernet_rules)/)
2926        {
2927
4
11
            $protocol->{flags}->{$flag} = 1;
2928        }
2929        else {
2930
0
0
            syntax_err("Unknown flag '$flag'");
2931        }
2932    }
2933
28
31
    return;
2934}
2935
2936sub read_typed_name_or_simple_protocol {
2937
350
0
430
    return (check_typed_name() || read_simple_protocol());
2938}
2939
2940sub read_protocol {
2941
28
0
35
    my $name = shift;
2942
28
37
    skip '=';
2943
28
53
    my $protocol = read_simple_protocol($name);
2944
28
47
    check_protocol_flags($protocol);
2945
28
40
    skip ';';
2946
28
39
    return $protocol;
2947}
2948
2949our %services;
2950
2951sub assign_union_allow_user {
2952
622
0
624
    my ($name) = @_;
2953
622
701
    skip $name;
2954
622
876
    skip '=';
2955
622
1065
    local $user_object->{active} = 1;
2956
622
619
    $user_object->{refcount} = 0;
2957
622
813
    my @result = read_union ';';
2958
622
1354
    return \@result, $user_object->{refcount};
2959}
2960
2961sub read_service {
2962
274
0
313
    my ($name) = @_;
2963
274
608
    my $service = { name => $name, rules => [] };
2964
274
473
    $service->{private} = $private if $private;
2965
274
354
    skip '=';
2966
274
402
    skip '\{';
2967
274
429
    add_description($service);
2968
274
268
    while (1) {
2969
282
367
        last if check 'user';
2970
8
19
        if (my $sub_owner = check_assign 'sub_owner', \&read_identifier) {
2971
1
2
            add_attribute($service, sub_owner => $sub_owner);
2972        }
2973        elsif (my @other = check_assign_list 'overlaps', \&read_typed_name) {
2974
4
7
            add_attribute($service, overlaps => \@other);
2975        }
2976        elsif (my $visible = check_assign('visible', \&read_owner_pattern)) {
2977
0
0
            add_attribute($service, visible => $visible);
2978        }
2979        elsif (check_flag('multi_owner')) {
2980
1
2
            $service->{multi_owner} = 1;
2981        }
2982        elsif (check_flag('unknown_owner')) {
2983
0
0
            $service->{unknown_owner} = 1;
2984        }
2985        elsif (check_flag('has_unenforceable')) {
2986
2
4
            $service->{has_unenforceable} = 1;
2987        }
2988        elsif (check_flag('disabled')) {
2989
0
0
            $service->{disabled} = 1;
2990        }
2991        else {
2992
0
0
            syntax_err("Expected some valid attribute or definition of 'user'");
2993        }
2994    }
2995
2996    # 'user' has already been read above.
2997
274
417
    skip '=';
2998
274
402
    if (check 'foreach') {
2999
0
0
        $service->{foreach} = 1;
3000    }
3001
274
504
    my @elements = read_list \&read_intersection;
3002
274
456
    $service->{user} = \@elements;
3003
3004
274
429
    while (1) {
3005
585
742
        last if check '\}';
3006
311
693
        if (my $action = check_permit_deny) {
3007
311
451
            my ($src, $src_user) = assign_union_allow_user 'src';
3008
311
435
            my ($dst, $dst_user) = assign_union_allow_user 'dst';
3009
311
946
            my $prt = [
3010                    read_assign_list(
3011                        'prt', \&read_typed_name_or_simple_protocol
3012                    )
3013               ];
3014
311
316
            my $log;
3015
311
551
            if (my @list = check_assign_list('log', \&read_identifier)) {
3016
18
20
                $log = \@list;
3017            }
3018            $src_user
3019
311
709
              or $dst_user
3020              or error_atline("Rule must use keyword 'user'");
3021
311
650
            if ($service->{foreach} and not($src_user and $dst_user)) {
3022
0
0
                warn_msg("Rule of $name should reference 'user'",
3023                         " in 'src' and 'dst'\n",
3024                         " because service has keyword 'foreach'");
3025            }
3026
311
1262
            my $rule = {
3027                service  => $service,
3028                action   => $action,
3029                src      => $src,
3030                dst      => $dst,
3031                prt      => $prt,
3032                has_user => $src_user ? $dst_user ? 'both' : 'src' : 'dst',
3033            };
3034
311
492
            $rule->{log} = $log if $log;
3035
311
311
257
624
            push @{ $service->{rules} }, $rule;
3036        }
3037        else {
3038
0
0
            syntax_err("Expected 'permit' or 'deny'");
3039        }
3040    }
3041
274
408
    return $service;
3042}
3043
3044our %pathrestrictions;
3045
3046sub read_pathrestriction {
3047
29
0
32
    my $name = shift;
3048
29
41
    skip '=';
3049
29
46
    my $restriction = new('Pathrestriction', name => $name);
3050
29
51
    $restriction->{private} = $private if $private;
3051
29
40
    add_description($restriction);
3052
29
49
    my @elements = read_list \&read_intersection;
3053
29
49
    $restriction->{elements} = \@elements;
3054
29
40
    return $restriction;
3055}
3056
3057sub read_attributed_object {
3058
40
0
36
    my ($name, $attr_descr) = @_;
3059
40
69
    my $object = { name => $name };
3060
40
56
    skip '=';
3061
40
58
    skip '\{';
3062
40
60
    add_description($object);
3063
40
39
    while (1) {
3064
282
333
        last if check '\}';
3065
242
333
        my $attribute = read_identifier;
3066
242
533
        my $val_descr = $attr_descr->{$attribute}
3067          or syntax_err("Unknown attribute '$attribute'");
3068
242
286
        skip '=';
3069
242
220
        my $val;
3070
242
417
        if (my $values = $val_descr->{values}) {
3071
174
218
            $val = read_identifier;
3072
174
1016
208
1418
            grep { $_ eq $val } @$values
3073              or syntax_err("Invalid value");
3074        }
3075        elsif (my $fun = $val_descr->{function}) {
3076
68
87
            $val = &$fun;
3077        }
3078        else {
3079
0
0
            internal_err();
3080        }
3081
242
287
        skip ';';
3082
242
348
        add_attribute($object, $attribute => $val);
3083    }
3084
40
108
    for my $attribute (keys %$attr_descr) {
3085
300
240
        my $description = $attr_descr->{$attribute};
3086
300
416
        unless (defined $object->{$attribute}) {
3087
58
79
            if (my $default = $description->{default}) {
3088
58
83
                $object->{$attribute} = $default;
3089            }
3090            else {
3091
0
0
                error_atline("Missing '$attribute' for $object->{name}");
3092            }
3093        }
3094
3095        # Convert from syntax to internal values, e.g. 'none' => undef.
3096
300
456
        if (my $map = $description->{map}) {
3097
140
129
            my $value = $object->{$attribute};
3098
140
258
            if (exists $map->{$value}) {
3099
47
78
                $object->{$attribute} = $map->{$value};
3100            }
3101        }
3102    }
3103
40
76
    return $object;
3104}
3105
3106my %isakmp_attributes = (
3107
3108    # This one is ignored and is optional.
3109    identity      => {
3110        values  => [qw( address fqdn )],
3111        default => 'none',
3112        map     => { none => undef }
3113    },
3114    nat_traversal => {
3115        values  => [qw( on additional off )],
3116        default => 'off',
3117        map     => { off => undef }
3118    },
3119    authentication => { values   => [qw( preshare rsasig )], },
3120    encryption     => { values   => [qw( aes aes192 aes256 des 3des )], },
3121    hash           => { values   => [qw( md5 sha sha256 sha384 sha512 )], },
3122    ike_version    => { values   => [ 1, 2 ], default => 1, },
3123    lifetime       => { function => \&read_time_val, },
3124    group          => { values   => [ 1, 2, 5, 14, 15, 16, 19, 20, 21, 24 ], },
3125    lifetime       => { function => \&read_time_val, },
3126    trust_point    => {
3127        function => \&read_identifier,
3128        default  => 'none',
3129        map      => { none => undef }
3130    },
3131);
3132
3133our %isakmp;
3134
3135sub read_isakmp {
3136
20
0
21
    my ($name) = @_;
3137
20
31
    return read_attributed_object $name, \%isakmp_attributes;
3138}
3139
3140my %ipsec_attributes = (
3141    key_exchange   => { function => \&read_typed_name, },
3142    esp_encryption => {
3143        values  => [qw( none aes aes192 aes256 des 3des )],
3144        default => 'none',
3145        map     => { none => undef }
3146    },
3147    esp_authentication => {
3148        values  => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )],
3149        default => 'none',
3150        map     => { none => undef,
3151
3152                     # Compatibility for old version.
3153                     md5_hmac => 'md5', sha_hmac => 'sha', }
3154    },
3155    ah => {
3156        values  => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )],
3157        default => 'none',
3158        map     => { none => undef, md5_hmac => 'md5', sha_hmac => 'sha', }
3159    },
3160    pfs_group => {
3161        values  => [qw( none 1 2 5 14 15 16 19 20 21 24 )],
3162        default => 'none',
3163        map     => { none => undef }
3164    },
3165    lifetime => { function => \&read_time_val, },
3166);
3167
3168our %ipsec;
3169
3170sub read_ipsec {
3171
20
0
18
    my ($name) = @_;
3172
20
36
    return read_attributed_object $name, \%ipsec_attributes;
3173}
3174
3175our %crypto;
3176
3177sub read_crypto {
3178
21
0
20
    my ($name) = @_;
3179
21
27
    skip '=';
3180
21
32
    skip '\{';
3181
21
36
    my $crypto = { name => $name };
3182
21
33
    $crypto->{private} = $private if $private;
3183
21
31
    add_description($crypto);
3184
21
21
    while (1) {
3185
45
54
        last if check '\}';
3186
24
38
        if (check_flag 'detailed_crypto_acl') {
3187
3
6
            $crypto->{detailed_crypto_acl} = 1;
3188        }
3189        elsif (my $type = check_assign 'type', \&read_typed_name) {
3190
21
41
            $crypto->{type}
3191              and error_atline("Redefining 'type' attribute");
3192
21
36
            $crypto->{type} = $type;
3193        }
3194        else {
3195
0
0
            syntax_err("Expected valid attribute");
3196        }
3197    }
3198
21
42
    $crypto->{type} or error_atline("Missing 'type' for $name");
3199
21
23
    return $crypto;
3200}
3201
3202our %owners;
3203
3204sub read_owner {
3205
64
0
66
    my $name = shift;
3206
64
85
    my $owner = new('Owner', name => $name);
3207
64
90
    skip '=';
3208
64
96
    skip '\{';
3209
64
105
    add_description($owner);
3210
64
63
    while (1) {
3211
154
187
        last if check '\}';
3212
90
161
        if (my $alias = check_assign('alias', \&read_string)) {
3213
3
5
            $owner->{alias}
3214              and error_atline("Redefining 'alias' attribute");
3215
3
6
            $owner->{alias} = $alias;
3216        }
3217        elsif (my @admins = check_assign_list('admins', \&read_name)) {
3218
59
111
            $owner->{admins}
3219              and error_atline("Redefining 'admins' attribute");
3220
59
116
            $owner->{admins} = \@admins;
3221        }
3222        elsif (my @watchers = check_assign_list('watchers', \&read_name)) {
3223
14
28
            if ($from_json->{watchers}) {
3224
0
0
                error_atline("Watchers must only be defined",
3225                             " in JSON/ directory");
3226            }
3227
14
24
            $owner->{watchers}
3228              and error_atline("Redefining 'watchers' attribute");
3229
14
26
            $owner->{watchers} = \@watchers;
3230        }
3231        elsif (check_flag 'extend_only') {
3232
9
17
            $owner->{extend_only} = 1;
3233        }
3234        elsif (check_flag 'extend_unbounded') {
3235
1
2
            $owner->{extend_unbounded} = 1;
3236        }
3237        elsif (check_flag 'extend') {
3238
3
7
            $owner->{extend} = 1;
3239        }
3240        elsif (check_flag 'show_all') {
3241
1
3
            $owner->{show_all} = 1;
3242        }
3243        else {
3244
0
0
            syntax_err("Expected valid attribute");
3245        }
3246    }
3247
64
133
    if (!$owner->{admins}) {
3248
5
19
        $owner->{extend_only} and $owner->{watchers} or
3249            error_atline("Missing attribute 'admins'");
3250
5
8
        $owner->{admins} = [];
3251    }
3252
64
75
    return $owner;
3253}
3254
3255my %global_type = (
3256    router          => [ \&read_router,          \%routers ],
3257    network         => [ \&read_network,         \%networks ],
3258    any             => [ \&read_aggregate,       \%aggregates ],
3259    area            => [ \&read_area,            \%areas ],
3260    owner           => [ \&read_owner,           \%owners ],
3261    group           => [ \&read_group,           \%groups ],
3262    protocol        => [ \&read_protocol,        \%protocols ],
3263    protocolgroup   => [ \&read_protocolgroup,   \%protocolgroups ],
3264    service         => [ \&read_service,         \%services ],
3265    pathrestriction => [ \&read_pathrestriction, \%pathrestrictions ],
3266    isakmp          => [ \&read_isakmp,          \%isakmp ],
3267    ipsec           => [ \&read_ipsec,           \%ipsec ],
3268    crypto          => [ \&read_crypto,          \%crypto ],
3269);
3270
3271sub read_netspoc {
3272
3273    # Check for global definitions.
3274
2288
0
2677
    my $pair = check_typed_name or syntax_err('');
3275
2288
3154
    my ($type, $name) = @$pair;
3276
2288
4421
    my $descr = $global_type{$type}
3277      or syntax_err("Unknown global definition");
3278
2288
2208
    my ($fun, $hash) = @$descr;
3279
2288
5661
    my $result = $fun->("$type:$name");
3280
2288
3407
    $result->{file} = $current_file;
3281
2288
4026
    if (my $other = $hash->{$name}) {
3282
0
0
        err_msg("Duplicate definition of $type:$name in",
3283                " $current_file and $other->{file}");
3284    }
3285
3286    # Result is not used in this module but can be useful
3287    # when this function is called from outside.
3288
2288
6114
    return $hash->{$name} = $result;
3289}
3290
3291# Read input from file and process it by function which is given as argument.
3292sub read_file {
3293
342
0
408
    local $current_file = shift;
3294
342
300
    my $read_syntax = shift;
3295
3296    # Read file as one large line.
3297
342
796
    local $/;
3298
342
304
    local $input;
3299
3300
342
510
    if (defined $current_file) {
3301
342
4043
        open(my $fh, '<', $current_file)
3302          or fatal_err("Can't open $current_file: $!");
3303
3304        # Fill buffer with content of whole file.
3305        # Content is implicitly freed when subroutine is left.
3306
342
4102
        $input = <$fh>;
3307
342
1357
        close $fh;
3308    }
3309    else {
3310
0
0
        $current_file = 'STDIN';
3311
0
0
        $input = <>;
3312    }
3313
342
418
    local $line = 1;
3314
342
1146
    my $length = length $input;
3315
342
577
    while (skip_space_and_comment, pos $input != $length) {
3316
2288
2564
        &$read_syntax;
3317    }
3318
342
1540
    return;
3319}
3320
3321# Try to read file 'config' in toplevel directory $path.
3322sub read_config {
3323
326
0
319
    my ($path) = @_;
3324
326
287
    my %result;
3325    my $read_config_data = sub {
3326
0
0
        my $key = read_identifier();
3327
0
0
        valid_config_key($key) or syntax_err("Invalid keyword");
3328
0
0
        skip('=');
3329
0
0
        my $val = read_identifier;
3330
0
0
        if (my $expected = check_config_pair($key, $val)) {
3331
0
0
            syntax_err("Expected value matching '$expected'");
3332        }
3333
0
0
        skip(';');
3334
0
0
        $result{$key} = $val;
3335
326
1069
    };
3336
3337
326
1993
    if (defined $path && -d $path) {
3338
305
4586
        opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3339
305
919
2268
1644
        if (grep { $_ eq 'config' } readdir $dh) {
3340
0
0
            $path = "$path/config";
3341
0
0
            read_file $path, $read_config_data;
3342        }
3343
305
1460
        closedir $dh;
3344    }
3345
326
1444
    return \%result;
3346}
3347
3348sub read_json_watchers {
3349
0
0
0
    my ($path) = @_;
3350
0
0
    opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3351
0
0
0
0
    my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3352
0
0
    closedir $dh;
3353
0
0
    for my $owner_name (@files) {
3354
0
0
        next if $owner_name =~ /^\./;
3355
0
0
        next if $owner_name =~ m/$config{ignore_files}/o;
3356
0
0
        my $path = "$path/$owner_name";
3357
0
0
        opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3358
0
0
0
0
        my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3359
0
0
        closedir $dh;
3360
0
0
        for my $file (@files) {
3361
0
0
            next if $file =~ /^\./;
3362
0
0
            next if $file =~ m/$config{ignore_files}/o;
3363
0
0
            my $path = "$path/$file";
3364
0
0
            if ($file ne 'watchers') {
3365
0
0
                err_msg("Ignoring $path");
3366
0
0
                next;
3367            }
3368
0
0
            open (my $fh, '<', $path) or fatal_err("Can't open $path");
3369
0
0
            my $data;
3370            {
3371
0
0
0
0
                local $/ = undef;
3372
0
0
                $data = from_json( <$fh> );
3373            }
3374
0
0
            close($fh);
3375
0
0
            my $owner = $owners{$owner_name};
3376
0
0
            if (! $owner) {
3377
0
0
                err_msg("Referencing unknown owner:$owner_name in $path");
3378
0
0
                next;
3379            }
3380
0
0
            $owner->{watchers} and
3381                err_msg("Redefining watcher of owner:$owner_name from $path");
3382
0
0
            $owner->{watchers} = $data;
3383        }
3384    }
3385
0
0
    return;
3386}
3387
3388sub read_json {
3389
0
0
0
    my ($path) = @_;
3390
0
0
    opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3391
0
0
0
0
    my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3392
0
0
    closedir $dh;
3393
0
0
    for my $file (@files) {
3394
0
0
        next if $file =~ /^\./;
3395
0
0
        next if $file =~ m/$config{ignore_files}/o;
3396
0
0
        my $path = "$path/$file";
3397
0
0
        if ($file ne 'owner') {
3398
0
0
            err_msg("Ignoring $path");
3399
0
0
            next;
3400        }
3401
0
0
        read_json_watchers($path);
3402    }
3403
0
0
    return;
3404}
3405
3406sub read_file_or_dir {
3407
337
0
369
    my ($path, $read_syntax) = @_;
3408
337
1101
    $read_syntax ||= \&read_netspoc;
3409
3410    # Handle toplevel file.
3411
337
1866
    if (!(defined $path && -d $path)) {
3412
32
61
        read_file($path, $read_syntax);
3413
32
54
        return;
3414    }
3415
3416    # Recursively read files and directories.
3417
305
260
    my $read_nested_files;
3418    my $read_nested_files0 = sub {
3419
313
322
        my ($path, $read_syntax) = @_;
3420
313
1148
        if (-d $path) {
3421
3
22
            opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3422
3
19
            while (my $file = Encode::decode($filename_encode, readdir $dh)) {
3423
10
34
                next if $file =~ /^\./;
3424
4
35
                next if $file =~ m/$config{ignore_files}/o;
3425
4
10
                my $path = "$path/$file";
3426
4
10
                $read_nested_files->($path, $read_syntax);
3427            }
3428
3
17
            closedir $dh;
3429        }
3430        else {
3431
310
483
            read_file $path, $read_syntax;
3432        }
3433
305
1137
    };
3434
3435    # Special handling for "*.private".
3436    $read_nested_files = sub {
3437
313
364
        my ($path, $read_syntax) = @_;
3438
3439        # Handle private directories and files.
3440
313
723
        if (my ($name) = ($path =~ m'([^/]*)\.private$')) {
3441
5
9
            if ($private) {
3442
1
4
                err_msg("Nested private context is not supported:\n $path");
3443            }
3444
5
7
            local $private = $name;
3445
5
9
            $read_nested_files0->($path, $read_syntax);
3446        }
3447        else {
3448
308
410
            $read_nested_files0->($path, $read_syntax);
3449        }
3450
305
712
    };
3451
3452    # Handle toplevel directory.
3453    # Special handling for "config", "raw" and "JSON".
3454
305
1902
    opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3455
305
919
1442
1719
    my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3456
305
854
    closedir $dh;
3457
3458
305
919
373
1538
    if (grep { $_ eq 'JSON' } @files) {
3459
0
0
        $can_json or
3460            fatal_err("JSON module must be installed to read $path/JSON");
3461
0
0
        $from_json = { JSON => 1 };
3462
0
0
        if (-e "$path/JSON/owner") {
3463
0
0
            $from_json->{watchers} = 1;
3464        }
3465    }
3466
3467
305
391
    for my $file (@files) {
3468
3469
919
2014
        next if $file =~ /^\./;
3470
309
1954
        next if $file =~ m/$config{ignore_files}/o;
3471
3472        # Ignore special files/directories.
3473
309
669
        next if $file =~ /^(config|raw|JSON)$/;
3474
3475
309
651
        my $path = "$path/$file";
3476
309
465
        $read_nested_files->($path, $read_syntax);
3477    }
3478
305
717
    if (keys %$from_json) {
3479
0
0
        read_json("$path/JSON");
3480    }
3481
305
729
    return;
3482}
3483
3484sub show_read_statistics {
3485
305
0
366
    my $n  = keys %networks;
3486
305
279
    my $h  = keys %hosts;
3487
305
293
    my $r  = keys %routers;
3488
305
269
    my $g  = keys %groups;
3489
305
277
    my $s  = keys %protocols;
3490
305
253
    my $sg = keys %protocolgroups;
3491
305
261
    my $p  = keys %services;
3492
305
946
    info("Read $r routers, $n networks, $h hosts");
3493
305
874
    info("Read $p services, $g groups, $s protocols, $sg protocol groups");
3494
305
309
    return;
3495}
3496
3497## no critic (RequireArgUnpacking RequireFinalReturn)
3498
3499# Type checking functions
3500
1734
0
4900
sub is_network       { ref($_[0]) eq 'Network'; }
3501
3835
0
9549
sub is_router        { ref($_[0]) eq 'Router'; }
3502
3010
0
9065
sub is_interface     { ref($_[0]) eq 'Interface'; }
3503
1002
0
1824
sub is_host          { ref($_[0]) eq 'Host'; }
3504
64
0
214
sub is_subnet        { ref($_[0]) eq 'Subnet'; }
3505
118
0
232
sub is_area          { ref($_[0]) eq 'Area'; }
3506
464
0
693
sub is_zone          { ref($_[0]) eq 'Zone'; }
3507
1246
0
3685
sub is_group         { ref($_[0]) eq 'Group'; }
3508
0
0
0
sub is_protocolgroup { ref($_[0]) eq 'Protocolgroup'; }
3509
2219
0
5533
sub is_objectgroup   { ref($_[0]) eq 'Objectgroup'; }
3510
128
0
294
sub is_chain         { ref($_[0]) eq 'Chain'; }
3511
1809
0
4011
sub is_autointerface { ref($_[0]) eq 'Autointerface'; }
3512
3513## use critic
3514
3515sub print_rule {
3516
61
0
57
    my ($rule) = @_;
3517
61
47
    my $extra = '';
3518
61
188
    my $service = $rule->{rule} && $rule->{rule}->{service};
3519
61
92
    $extra .= " $rule->{for_router}" if $rule->{for_router};
3520
61
92
    $extra .= " stateless"           if $rule->{stateless};
3521
61
80
    $extra .= " stateless_icmp"      if $rule->{stateless_icmp};
3522
61
128
    $extra .= " of $service->{name}" if $service;
3523
61
142
    my $prt = $rule->{orig_prt} || $rule->{prt};
3524
61
88
    my $action = $rule->{deny} ? 'deny' : 'permit';
3525
61
100
    if (my $chain = $rule->{chain}) {
3526
0
0
        $action = $chain->{name};
3527    }
3528    return
3529
61
361
        $action
3530      . " src=$rule->{src}->{name}; dst=$rule->{dst}->{name}; "
3531      . "prt=$prt->{name};$extra";
3532}
3533
3534##############################################################################
3535# Order protocols
3536##############################################################################
3537
3538# Hash for converting a reference of a protocol back to this protocol.
3539our %ref2prt;
3540
3541# Look up a protocol object by its defining attributes.
3542my %prt_hash;
3543
3544sub prepare_prt_ordering {
3545
4954
0
3830
    my ($prt) = @_;
3546
4954
4556
    my $proto = $prt->{proto};
3547
4954
3685
    my $main_prt;
3548
4954
14543
    if ($proto eq 'tcp' or $proto eq 'udp') {
3549
3550        # Convert src and dst port ranges from arrays to real protocol objects.
3551        # This is used in function expand_rules via expand_protocols:
3552        # An unexpanded rule has references to TCP and UDP protocols
3553        # with combined src and dst port ranges. An expanded rule has
3554        # distinct references to src and dst protocols with a single
3555        # port range.
3556
2577
2458
        for my $where ('src_range', 'dst_range') {
3557
3558            # An array with low and high port.
3559
5154
8201
            my $range     = $prt->{$where} or next;
3560
3246
5962
            my $key       = join ':', @$range;
3561
3246
3539
            my $range_prt = $prt_hash{$proto}->{$key};
3562
3246
4147
            if (not $range_prt) {
3563
2225
4570
                $range_prt = {
3564                    name  => $prt->{name},
3565                    proto => $proto,
3566                    range => $range,
3567                };
3568
2225
2977
                $prt_hash{$proto}->{$key} = $range_prt;
3569
3570                # Set up ref2prt.
3571
2225
4418
                $ref2prt{$range_prt} = $range_prt;
3572            }
3573
3246
5535
            $prt->{$where} = $range_prt;
3574        }
3575    }
3576    elsif ($proto eq 'icmp') {
3577
365
533
        my $type = $prt->{type};
3578
365
349
        my $code = $prt->{code};
3579
365
537
        my $key  = defined $type ? (defined $code ? "$type:$code" : $type) : '';
3580
365
1077
        $main_prt = $prt_hash{$proto}->{$key}
3581          or $prt_hash{$proto}->{$key} = $prt;
3582    }
3583    elsif ($proto eq 'ip') {
3584
356
775
        $main_prt = $prt_hash{$proto}
3585          or $prt_hash{$proto} = $prt;
3586    }
3587    else {
3588
3589        # Other protocol.
3590
1656
1436
        my $key = $proto;
3591
1656
3365
        $main_prt = $prt_hash{proto}->{$key}
3592          or $prt_hash{proto}->{$key} = $prt;
3593    }
3594
4954
6883
    if ($main_prt) {
3595
3596        # Found duplicate protocol definition.  Link $prt with $main_prt.
3597        # We link all duplicate protocols to the first protocol found.
3598        # This assures that we always reach the main protocol from any duplicate
3599        # protocol in one step via ->{main}.  This is used later to substitute
3600        # occurrences of $prt with $main_prt.
3601
33
44
        $prt->{main} = $main_prt;
3602    }
3603
4954
5275
    return;
3604}
3605
3606sub order_icmp {
3607
331
0
325
    my ($hash, $up) = @_;
3608
3609    # Handle 'icmp any'.
3610
331
590
    if (my $prt = $hash->{''}) {
3611
331
325
        $prt->{up} = $up;
3612
331
481
        $up = $prt;
3613    }
3614
331
583
    for my $prt (values %$hash) {
3615
3616        # 'icmp any' has been handled above.
3617
358
620
        if (!defined $prt->{type}) {
3618        }
3619        elsif (defined $prt->{code}) {
3620
0
0
            $prt->{up} = ($hash->{ $prt->{type} } or $up);
3621        }
3622        else {
3623
27
33
            $prt->{up} = $up;
3624        }
3625
3626        # Set up ref2prt.
3627
358
1928
        $ref2prt{$prt} = $prt;
3628    }
3629
331
403
    return;
3630}
3631
3632sub order_proto {
3633
331
0
322
    my ($hash, $up) = @_;
3634
331
553
    for my $prt (values %$hash) {
3635
1655
1478
        $prt->{up} = $up;
3636
3637        # Set up ref2prt.
3638
1655
2440
        $ref2prt{$prt} = $prt;
3639    }
3640
331
369
    return;
3641}
3642
3643# Set {up} relation from port range to the smallest port range which
3644# includes it.
3645# If no including range is found, link it with next larger protocol.
3646# Set attribute {has_neighbor} to range adjacent to upper port.
3647# Find overlapping ranges and split one of them to eliminate the overlap.
3648# Set attribute {split} at original range, referencing pair of splitted ranges.
3649sub order_ranges {
3650
662
0
641
    my ($range_href, $up) = @_;
3651
2801
5335
    my @sorted =
3652
3653      # Sort by low port. If low ports are equal, sort reverse by high port.
3654      # I.e. larger ranges coming first, if there are multiple ranges
3655      # with identical low port.
3656      sort {
3657
662
1604
             $a->{range}->[0] <=> $b->{range}->[0]
3658          || $b->{range}->[1] <=> $a->{range}->[1]
3659      } values %$range_href;
3660
3661    # Check current range [a1, a2] for sub-ranges, starting at position $i.
3662    # Return position of range which isn't sub-range or undef
3663    # if end of array is reached.
3664
662
497
    my $check_subrange;
3665
3666    $check_subrange = sub  {
3667
2225
2662
        my ($a, $a1, $a2, $i) = @_;
3668
2225
1602
        while (1) {
3669
3279
4754
            return if $i == @sorted;
3670
2617
2065
            my $b = $sorted[$i];
3671
2617
2617
1834
3283
            my ($b1, $b2) = @{ $b->{range} };
3672
3673            # Neighbors
3674            # aaaabbbb
3675
2617
3610
            if ($a2 + 1 == $b1) {
3676
3677                # Mark protocol as candidate for joining of port ranges during
3678                # optimization.
3679
36
47
                $a->{has_neighbor} = $b->{has_neighbor} = 1;
3680            }
3681
3682            # Not related.
3683            # aaaa    bbbbb
3684
2617
3834
            return $i if $a2 < $b1;
3685
3686            # $a includes $b.
3687            # aaaaaaa
3688            #  bbbbb
3689
1564
2109
            if ($a2 >= $b2) {
3690
1563
1406
                $b->{up} = $a;
3691
3692#           debug("$b->{name} [$b1-$b2] < $a->{name} [$a1-$a2]");
3693
1563
2892
                $i = $check_subrange->($b, $b1, $b2, $i + 1);
3694
3695                # Stop at end of array.
3696
1563
2584
                $i or return;
3697
1053
896
                next;
3698            }
3699
3700            # $a and $b are overlapping.
3701            # aaaaa
3702            #   bbbbbb
3703            # Split $b in two parts $x and $y with $x included by $b:
3704            # aaaaa
3705            #   xxxyyy
3706
1
1
            my $x1 = $b1;
3707
1
2
            my $x2 = $a2;
3708
1
1
            my $y1 = $a2 + 1;
3709
1
1
            my $y2 = $b2;
3710
3711#        debug("$b->{name} [$b1-$b2] split into [$x1-$x2] and [$y1-$y2]");
3712            my $find_or_insert_range = sub {
3713
2
3
                my ($a1, $a2, $i, $orig, $prefix) = @_;
3714
2
2
                while (1) {
3715
3
4
                    if ($i == @sorted) {
3716
1
1
                        last;
3717                    }
3718
2
3
                    my $b = $sorted[$i];
3719
2
2
2
3
                    my ($b1, $b2) = @{ $b->{range} };
3720
3721                    # New range starts at higher position and therefore must
3722                    # be inserted behind current range.
3723
2
4
                    if ($a1 > $b1) {
3724
1
1
                        $i++;
3725
1
1
                        next;
3726                    }
3727
3728                    # New and current range start a same position.
3729
1
2
                    if ($a1 == $b1) {
3730
3731                        # New range is smaller and therefore must be inserted
3732                        # behind current range.
3733
1
2
                        if ($a2 < $b2) {
3734
0
0
                            $i++;
3735
0
0
                            next;
3736                        }
3737
3738                        # Found identical range, return this one.
3739
1
2
                        if ($a2 == $b2) {
3740
3741#                    debug("Splitted range is already defined: $b->{name}");
3742
1
2
                            return $b;
3743                        }
3744
3745                        # New range is larger than current range and therefore
3746                        # must be inserted in front of current one.
3747
0
0
                        last;
3748                    }
3749
3750                    # New range starts at lower position than current one.
3751                    # It must be inserted in front of current range.
3752
0
0
                    last;
3753                }
3754
1
5
                my $new_range = {
3755                    name  => "$prefix$orig->{name}",
3756                    proto => $orig->{proto},
3757                    range => [ $a1, $a2 ],
3758
3759                    # Mark for range optimization.
3760                    has_neighbor => 1
3761                };
3762
3763                # Insert new range at position $i.
3764
1
4
                splice @sorted, $i, 0, $new_range;
3765
3766                # Set up ref2prt.
3767
1
1
                $ref2prt{$new_range} = $new_range;
3768
3769
1
2
                return $new_range;
3770
1
4
            };
3771
1
2
            my $left  = $find_or_insert_range->($x1, $x2, $i + 1, $b, 'lpart_');
3772
1
2
            my $rigth = $find_or_insert_range->($y1, $y2, $i + 1, $b, 'rpart_');
3773
1
2
            $b->{split} = [ $left, $rigth ];
3774
3775            # Continue processing with next element.
3776
1
5
            $i++;
3777        }
3778
662
2339
    };
3779
3780    # Array wont be empty because $prt_tcp and $prt_udp are defined internally.
3781
662
1127
    @sorted or internal_err("Unexpected empty array");
3782
3783
662
576
    my $a = $sorted[0];
3784
662
683
    $a->{up} = $up;
3785
662
662
528
1027
    my ($a1, $a2) = @{ $a->{range} };
3786
3787    # Ranges "TCP any" and "UDP any" 1..65535 are defined internally,
3788    # they include all other ranges.
3789
662
2119
    $a1 == 1 and $a2 == 65535
3790      or internal_err("Expected $a->{name} to have range 1..65535");
3791
3792    # There can't be any port which isn't included by ranges "TCP any"
3793    # or "UDP any".
3794
662
916
    $check_subrange->($a, $a1, $a2, 1) and internal_err();
3795
662
744
    return;
3796}
3797
3798sub expand_splitted_protocol {
3799
290
0
281
    my ($prt) = @_;
3800
3801    # Handle unset src_range.
3802
290
585
    if (not $prt) {
3803
19
30
        return $prt;
3804    }
3805    elsif (my $split = $prt->{split}) {
3806
1
1
        my ($prt1, $prt2) = @$split;
3807
1
3
        return (expand_splitted_protocol($prt1),
3808                expand_splitted_protocol($prt2));
3809    }
3810    else {
3811
270
391
        return $prt;
3812    }
3813}
3814
3815# Protocol 'ip' is needed later for implementing secondary rules and
3816# automatically generated deny rules.
3817my $prt_ip;
3818
3819# Protocol 'ICMP any', needed in optimization of chains for iptables.
3820my $prt_icmp;
3821
3822# Protocol 'TCP any'.
3823my $prt_tcp;
3824
3825# Protocol 'UDP any'.
3826my $prt_udp;
3827
3828# DHCP server.
3829my $prt_bootps;
3830
3831# IPSec: Internet key exchange.
3832# Source and destination port (range) is set to 500.
3833my $prt_ike;
3834
3835# IPSec: NAT traversal.
3836my $prt_natt;
3837
3838# IPSec: encryption security payload.
3839my $prt_esp;
3840
3841# IPSec: authentication header.
3842my $prt_ah;
3843
3844# Port range 'TCP any'; assigned in sub order_protocols below.
3845my $range_tcp_any;
3846
3847# Port range 'tcp established' is needed later for reverse rules
3848# and assigned below.
3849my $range_tcp_established;
3850
3851# Order protocols. We need this to simplify optimization.
3852# Additionally add internal predefined protocols.
3853sub order_protocols {
3854
331
0
453
    progress('Arranging protocols');
3855
3856    # Internal protocols need to be processed before user defined protocols,
3857    # because we want to avoid handling of {main} for internal protocols.
3858    # $prt_tcp and $prt_udp need to be processed before all other TCP and UDP
3859    # protocols, because otherwise the range 1..65535 would get a misleading
3860    # name.
3861
331
2317
718
3917
    for my $prt (
3862        $prt_ip,  $prt_icmp, $prt_tcp,
3863        $prt_udp, $prt_bootps, $prt_ike,  $prt_natt,
3864        $prt_esp, $prt_ah,
3865        map({ $_->{prt} ? ($_->{prt}) : () }
3866            values %routing_info, values %xxrp_info),
3867        values %protocols
3868      )
3869    {
3870
4954
5354
        prepare_prt_ordering $prt;
3871    }
3872
3873
331
456
    $range_tcp_any         = $prt_tcp->{dst_range};
3874
331
1262
    $range_tcp_established = {
3875        %$range_tcp_any,
3876        name        => 'reversed:TCP_ANY',
3877        established => 1
3878    };
3879
331
666
    $range_tcp_established->{up} = $range_tcp_any;
3880
3881
331
282
    my $up = $prt_ip;
3882
331
568
    order_ranges($prt_hash{tcp}, $up);
3883
331
464
    order_ranges($prt_hash{udp}, $up);
3884
331
508
    order_icmp($prt_hash{icmp}, $up);
3885
331
461
    order_proto($prt_hash{proto}, $up);
3886
3887    # Set up ref2prt.
3888
331
458
    $ref2prt{$prt_ip} = $prt_ip;
3889
331
330
    return;
3890}
3891
3892####################################################################
3893# Link topology elements each with another
3894####################################################################
3895
3896sub expand_group;
3897
3898sub link_to_owner {
3899
2401
0
1856
    my ($obj, $key) = @_;
3900
2401
5014
    $key ||= 'owner';
3901
2401
3476
    if (my $value = $obj->{$key}) {
3902
66
125
        if (my $owner = $owners{$value}) {
3903
64
127
            return $obj->{$key} = $owner;
3904        }
3905
2
8
        err_msg("Can't resolve reference to '$value'",
3906                " in attribute '$key' of $obj->{name}");
3907
2
4
        delete $obj->{$key};
3908    }
3909
2337
3462
    return;
3910}
3911
3912sub link_to_real_owner {
3913
2335
0
1897
    my ($obj, $key) = @_;
3914
2335
2514
    if (my $owner = link_to_owner($obj, $key)) {
3915
39
70
        if ($owner->{extend_only}) {
3916
3917            # Prevent further errors.
3918
3
4
            delete $owner->{extend_only};
3919
3
11
            err_msg("$owner->{name} with attribute 'extend_only'",
3920                    " must only be used at area,\n not at $obj->{name}");
3921        }
3922    }
3923
2335
2253
    return;
3924}
3925
3926# Element of attribute 'watchers' of owner A is allowed to reference
3927# some other owner B. In this case all admins and watchers of B are
3928# added to watchers of A.
3929sub expand_watchers {
3930
69
0
68
    my ($owner) = @_;
3931
69
75
    my $names = $owner->{watchers};
3932
3933    # No wathers given.
3934
69
98
    if (!$names) {
3935
51
67
        return $owner->{admins};
3936    }
3937
3938    # Owners, referenced in $names have already been resolved.
3939
18
31
    if ($owner->{watching_owners}) {
3940
3
3
3
6
        return [ @{ $owner->{admins} }, @$names ];
3941    }
3942
15
29
    if ($names eq 'recursive') {
3943
1
3
        err_msg("Found recursive definition of watchers in $owner->{name}");
3944
1
4
        return $owner->{watchers} = [];
3945    }
3946
14
15
    $owner->{watchers} = 'recursive';
3947
14
17
    my $watching_owners = [];
3948
14
12
    my @expanded;
3949
14
18
    for my $name (@$names) {
3950
15
41
        if (my ($o_name) = ($name =~ /^owner:(.*)$/)) {
3951
6
8
            my $owner_b = $owners{$o_name};
3952
6
10
            if (!$owner_b) {
3953
1
5
                err_msg("Unknown owner:$o_name referenced in watcher of",
3954                        " $owner->{name}");
3955
1
2
                next;
3956            }
3957
5
5
            push @$watching_owners, $owner_b;
3958
5
5
5
15
            push @expanded, @{ expand_watchers($owner_b) };
3959        }
3960        else {
3961
9
21
            push @expanded, $name;
3962        }
3963    }
3964
14
21
    $owner->{watchers} = \@expanded;
3965
3966    # Mark: no need to expand again and for cut-netspoc.
3967
14
14
    $owner->{watching_owners} = $watching_owners;
3968
3969
14
14
13
39
    return [ @{ $owner->{admins} }, @expanded ];
3970}
3971
3972sub link_owners {
3973
3974
337
0
274
    my %alias2owner;
3975
3976    # Use sort to get deterministic error messages.
3977
337
860
    for my $name (sort keys %owners) {
3978
64
81
        my $owner = $owners{$name};
3979
3980        # Check for unique alias names.
3981
64
202
        my $alias = $owner->{alias} || $name;
3982
64
107
        if (my $other = $alias2owner{$alias}) {
3983
2
2
            my $descr1 = $owner->{name};
3984
2
7
            $owner->{alias} and $descr1 .= " with alias '$owner->{alias}'";
3985
2
2
            my $descr2 = $other->{name};
3986
2
5
            $other->{alias} and $descr2 .= " with alias '$other->{alias}'";
3987
2
6
            err_msg("Name conflict between owners\n - $descr1\n - $descr2");
3988        }
3989        else {
3990
62
84
            $alias2owner{$alias} = $owner;
3991        }
3992
3993        # Check and expand referenced owners in watchers.
3994
64
86
        expand_watchers($owner);
3995
3996        # Check email addresses in admins and watchers.
3997
64
76
        for my $attr (qw( admins watchers )) {
3998
128
128
100
235
            for my $email (@{ $owner->{$attr} }) {
3999
4000                # Check email syntax.
4001                # Only 7 bit ASCII
4002                # Local part definition from wikipedia,
4003                # without space and other quoted characters
4004
74
61
                do {
4005
70
70
70
452
89
374
                    use bytes;
4006
74
4459
                    $email =~
4007                        m/^ [\w.!\#$%&''*+\/=?^_``{|}~-]+ \@ [\w.-]+ $/x ||
4008                        $email eq 'guest';
4009                }
4010                or err_msg("Invalid email address (ASCII only)",
4011                           " in $attr of $owner->{name}: $email");
4012
4013                # Normalize email to lower case.
4014
74
325
                $email = lc($email);
4015            }
4016        }
4017
4018        # Check for duplicate email addresses
4019        # in admins, watchers and between admins and watchers.
4020
64
64
64
63
74
106
        if (find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} })) {
4021
1
2
            for my $attr (qw(admins watchers)) {
4022
2
2
2
4
                if (my @emails = find_duplicates(@{ $owner->{$attr} })) {
4023
1
1
2
2
                    $owner->{$attr} = [ unique(@{ $owner->{$attr} }) ];
4024
1
6
                    err_msg("Duplicates in $attr of $owner->{name}: ",
4025                              join(', ', @emails));
4026                }
4027            }
4028
1
1
2
2
            if (my @duplicates =
4029
1
1
                find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} }))
4030            {
4031
1
4
                err_msg("Duplicates in admins/watchers of $owner->{name}: ",
4032                          join(', ', @duplicates));
4033            }
4034        }
4035    }
4036
337
672
    for my $network (values %networks) {
4037
1115
1274
        link_to_real_owner($network);
4038
1115
1115
783
1851
        for my $host (@{ $network->{hosts} }) {
4039
181
219
            link_to_real_owner($host);
4040        }
4041    }
4042
337
562
    for my $aggregate (values %aggregates) {
4043
52
64
        link_to_real_owner($aggregate);
4044    }
4045
337
529
    for my $area (values %areas) {
4046
66
80
        link_to_owner($area);
4047
66
142
        if (my $router_attributes = $area->{router_attributes}) {
4048
7
62
            link_to_real_owner($router_attributes);
4049        }
4050    }
4051
337
500
    for my $router (values %routers, @router_fragments) {
4052
690
773
        link_to_real_owner($router);
4053
690
1414
        $router->{model}->{has_vip} or next;
4054
7
7
8
10
        for my $interface (@{ $router->{interfaces} }) {
4055
16
20
            link_to_real_owner($interface);
4056        }
4057    }
4058
337
525
    for my $service (values %services) {
4059
274
330
        link_to_real_owner($service, 'sub_owner');
4060    }
4061
337
399
    return;
4062}
4063
4064sub link_policy_distribution_point {
4065
697
0
589
    my ($obj) = @_;
4066
697
1254
    my $pair = $obj->{policy_distribution_point} or return;
4067
10
15
    my ($type, $name) = @$pair;
4068
10
21
    if ($type ne 'host') {
4069
0
0
        err_msg("Must only use 'host' in 'policy_distribution_point'",
4070                " of $obj->{name}");
4071
4072        # Prevent further errors;
4073
0
0
        delete $obj->{policy_distribution_point};
4074
0
0
        return;
4075    }
4076
10
13
    my $host = $hosts{$name};
4077
10
22
    if (!$host) {
4078
0
0
        warn_msg("Ignoring undefined host:$name",
4079                 " in 'policy_distribution_point' of $obj->{name}");
4080
4081        # Prevent further errors;
4082
0
0
        delete $obj->{policy_distribution_point};
4083
0
0
        return;
4084    }
4085
10
12
    $obj->{policy_distribution_point} = $host;
4086
10
14
    return;
4087}
4088
4089sub link_general_permit {
4090
697
0
597
    my ($obj) = @_;
4091
697
1388
    my $list = $obj->{general_permit} or return;
4092
21
24
    my $context = $obj->{name};
4093
4094    # Sort protocols and src_range/dst_range/orig_prt triples by name,
4095    # so we can compare value lists of attribute general_permit for
4096    # redundancy during inheritance.
4097
9
33
    $list = $obj->{general_permit} =
4098
21
32
        [ sort { (ref $a eq 'ARRAY' ? $a->[2]->{name} : $a->{name})
4099                 cmp
4100                 (ref $b eq 'ARRAY' ? $b->[2]->{name} : $b->{name}) }
4101
21
16
          @{ split_protocols(expand_protocols($list, $context)) } ];
4102
4103    # Don't allow port ranges. This wouldn't work, because
4104    # gen_reverse_rules doesn't handle generally permitted protocols.
4105
21
39
    for my $prt (@$list) {
4106
28
23
        my $orig_prt;
4107        my $src_range;
4108
0
0
        my $range;
4109
28
44
        if (ref $prt eq 'ARRAY') {
4110
5
6
            ($src_range, my $dst_range, $orig_prt) = @$prt;
4111
5
6
            $range = $dst_range->{range};
4112        }
4113        else {
4114
23
55
            $range = $prt->{range} or next;
4115
1
1
            $orig_prt = $prt;
4116        }
4117
6
6
        my @reason;
4118
6
10
        if (my $flags = $orig_prt->{flags}) {
4119
0
0
            push @reason, 'modifiers';
4120        }
4121
6
26
        if ($src_range || $range && $range ne $aref_tcp_any) {
4122
2
2
            push @reason, 'ports';
4123        }
4124
6
15
        if (@reason) {
4125
2
3
            my $reason = join ' or ', @reason;
4126
2
8
            err_msg("Must not use '$orig_prt->{name}' with $reason",
4127                    " in general_permit of $context");
4128        }
4129    }
4130
21
32
    return;
4131}
4132
4133# Link areas with referenced interfaces or network.
4134sub link_areas {
4135
337
0
536
    for my $area (values %areas) {
4136
66
115
        if ($area->{anchor}) {
4137
17
41
            my @elements =
4138
17
19
              @{ expand_group([ $area->{anchor} ], $area->{name}) };
4139
17
41
            if (@elements == 1) {
4140
17
19
                my $obj = $elements[0];
4141
17
28
                if (is_network $obj) {
4142
17
28
                    $area->{anchor} = $obj;
4143                }
4144                else {
4145
0
0
                    err_msg
4146                      "Unexpected $obj->{name} in anchor of $area->{name}";
4147
4148                    # Prevent further errors.
4149
0
0
                    delete $area->{anchor};
4150                }
4151            }
4152            else {
4153
0
0
                err_msg
4154                  "Expected exactly one element in anchor of $area->{name}";
4155
0
0
                delete $area->{anchor};
4156            }
4157
4158        }
4159        else {
4160
49
57
            for my $attr (qw(border inclusive_border)) {
4161
98
200
                next if !$area->{$attr};
4162
52
109
                $area->{$attr} = expand_group($area->{$attr}, $area->{name});
4163
52
52
82
74
                for my $obj (@{ $area->{$attr} }) {
4164
62
86
                    if (is_interface $obj) {
4165
62
68
                        my $router = $obj->{router};
4166
62
103
                        $router->{managed}
4167                          or err_msg "Referencing unmanaged $obj->{name} ",
4168                          "from $area->{name}";
4169
4170                        # Reverse swapped main and virtual interface.
4171
62
172
                        if (my $main_interface = $obj->{main_interface}) {
4172
2
5
                            $obj = $main_interface;
4173                        }
4174                    }
4175                    else {
4176
0
0
                        err_msg
4177                            "Unexpected $obj->{name} in $attr of $area->{name}";
4178
4179                        # Prevent further errors.
4180
0
0
                        delete $area->{$attr};
4181                    }
4182                }
4183            }
4184        }
4185
66
162
        if (my $router_attributes = $area->{router_attributes}) {
4186
7
10
            link_policy_distribution_point($router_attributes);
4187
7
9
            link_general_permit($router_attributes);
4188        }
4189    }
4190
337
319
    return;
4191}
4192
4193# Link interfaces with networks in both directions.
4194sub link_interfaces {
4195
690
0
586
    my ($router) = @_;
4196
690
690
546
952
    for my $interface (@{ $router->{interfaces} }) {
4197
1588
1696
        my $net_name = $interface->{network};
4198
1588
1827
        my $network  = $networks{$net_name};
4199
4200
1588
2282
        unless ($network) {
4201
0
0
            my $msg = "Referencing undefined network:$net_name"
4202              . " from $interface->{name}";
4203
0
0
            if ($interface->{disabled}) {
4204
0
0
                warn_msg($msg);
4205            }
4206            else {
4207
0
0
                err_msg($msg);
4208
4209                # Prevent further errors.
4210
0
0
                $interface->{disabled} = 1;
4211            }
4212
4213            # Prevent further errors.
4214            # This case is handled in disable_behind.
4215
0
0
            $interface->{network} = undef;
4216
0
0
            next;
4217        }
4218
4219
1588
1426
        $interface->{network} = $network;
4220
4221        # Private network must be connected to private interface
4222        # of same context.
4223
1588
2544
        if (my $private1 = $network->{private}) {
4224
3
4
            if (my $private2 = $interface->{private}) {
4225
2
10
                $private1 eq $private2
4226                  or err_msg("$private2.private $interface->{name} must not",
4227                             " be connected to $private1.private",
4228                             " $network->{name}");
4229            }
4230            else {
4231
1
5
                err_msg("Public $interface->{name} must not be connected to",
4232                        " $private1.private $network->{name}");
4233            }
4234        }
4235
4236        # Public network may connect to private interface.
4237        # The owner of a private context can prevent a public network from
4238        # connecting to a private interface by simply connecting an own private
4239        # network to the private interface.
4240
4241
1588
1588
1141
2252
        push @{ $network->{interfaces} }, $interface;
4242
1588
1993
        check_interface_ip($interface, $network);
4243    }
4244
690
714
    return;
4245}
4246
4247sub check_interface_ip {
4248
1608
0
1344
    my ($interface, $network) = @_;
4249
1608
1513
    my $ip         = $interface->{ip};
4250
1608
1376
    my $network_ip = $network->{ip};
4251
1608
5487
    if ($ip =~ /^(?:short|tunnel)$/) {
4252
4253        # Nothing to check:
4254        # short interface may be linked to arbitrary network,
4255        # tunnel interfaces and networks have been generated internally.
4256    }
4257    elsif ($ip eq 'unnumbered') {
4258
13
20
        $network_ip eq 'unnumbered'
4259          or err_msg("Unnumbered $interface->{name} must not be linked ",
4260                     "to $network->{name}");
4261    }
4262    elsif ($network_ip eq 'unnumbered') {
4263
0
0
        err_msg("$interface->{name} must not be linked ",
4264                "to unnumbered $network->{name}");
4265    }
4266    elsif ($ip eq 'negotiated') {
4267    }
4268    elsif ($ip eq 'bridged') {
4269
4270        # Nothing to be checked: attribute 'bridged' is set automatically
4271        # for an interface without IP and linked to bridged network.
4272    }
4273    else {
4274
4275        # Check compatibility of interface IP and network IP/mask.
4276
1330
1142
        my $mask = $network->{mask};
4277
1330
1620
        if (not(match_ip($ip, $network_ip, $mask))) {
4278
0
0
            err_msg("$interface->{name}'s IP doesn't match ",
4279                    "$network->{name}'s IP/mask");
4280        }
4281
1330
1768
        if ($mask == 0xffffffff) {
4282
40
72
            if (not $network->{loopback}) {
4283
1
5
                warn_msg("$interface->{name} has address of its network.\n",
4284                         " Remove definition of $network->{name} and\n",
4285                         " add attribute 'loopback' at",
4286                         " interface definition.");
4287            }
4288        }
4289        else {
4290
1290
2091
            if ($ip == $network_ip) {
4291
0
0
                err_msg("$interface->{name} has address of its network");
4292            }
4293
1290
1484
            my $broadcast = $network_ip + complement_32bit $mask;
4294
1290
1968
            if ($ip == $broadcast) {
4295
0
0
                err_msg("$interface->{name} has broadcast address");
4296            }
4297        }
4298    }
4299
1608
2578
    return;
4300}
4301
4302# Iterate over all interfaces of all routers.
4303# Don't use values %interfaces because we want to traverse the interfaces
4304# in a deterministic order.
4305sub link_routers {
4306
337
0
947
    for my $router (sort(by_name values %routers), @router_fragments) {
4307
690
874
        link_interfaces($router);
4308
690
888
        link_policy_distribution_point($router);
4309
690
773
        link_general_permit($router);
4310    }
4311
337
341
    return;
4312}
4313
4314sub link_subnet  {
4315
1251
0
1031
    my ($object, $parent) = @_;
4316
4317    my $context = sub {
4318
1
7
        !$parent        ? $object->{name}
4319          : ref $parent ? "$object->{name} of $parent->{name}"
4320          :               "$parent $object->{name}";
4321
1251
2705
    };
4322
1251
4258
    return if not $object->{subnet_of};
4323
36
36
38
66
    my ($type, $name) = @{ $object->{subnet_of} };
4324
36
81
    if ($type ne 'network') {
4325
0
0
        err_msg "Attribute 'subnet_of' of ", $context->(), "\n",
4326          " must not be linked to $type:$name";
4327
4328        # Prevent further errors;
4329
0
0
        delete $object->{subnet_of};
4330
0
0
        return;
4331    }
4332
36
49
    my $network = $networks{$name};
4333
36
69
    if (not $network) {
4334
0
0
        warn_msg("Ignoring undefined network:$name",
4335                 " from attribute 'subnet_of'\n of ", $context->());
4336
4337        # Prevent further errors;
4338
0
0
        delete $object->{subnet_of};
4339
0
0
        return;
4340    }
4341
36
40
    $object->{subnet_of} = $network;
4342
36
56
    my $ip     = $network->{ip};
4343
36
33
    my $mask   = $network->{mask};
4344
36
44
    my $sub_ip = $object->{ip};
4345
4346#    debug($network->{name}) if not defined $ip;
4347
36
71
    if ($ip eq 'unnumbered') {
4348
0
0
        err_msg "Unnumbered $network->{name} must not be referenced from",
4349          " attribute 'subnet_of'\n of ", $context->();
4350
4351        # Prevent further errors;
4352
0
0
        delete $object->{subnet_of};
4353
0
0
        return;
4354    }
4355
4356    # $sub_mask needs not to be tested here,
4357    # because it has already been checked for $object.
4358
36
53
    if (not(match_ip($sub_ip, $ip, $mask))) {
4359
1
2
        err_msg $context->(), " is subnet_of $network->{name}",
4360          " but its IP doesn't match that's IP/mask";
4361    }
4362
36
117
    return;
4363}
4364
4365sub link_subnets  {
4366
337
0
495
    for my $network (values %networks) {
4367
1115
1285
        link_subnet($network, undef);
4368    }
4369
337
637
    for my $obj (values %networks, values %aggregates, values %areas) {
4370
1233
2036
        my $nat = $obj->{nat} or next;
4371
106
106
92
162
        for my $nat (values %{ $obj->{nat} }) {
4372
136
150
            link_subnet($nat, $obj);
4373        }
4374    }
4375
337
332
    return;
4376}
4377
4378my @pathrestrictions;
4379
4380sub add_pathrestriction {
4381
28
0
31
    my ($name, $elements) = @_;
4382
28
34
    my $restrict = new('Pathrestriction', name => $name, elements => $elements);
4383
28
32
    for my $interface (@$elements) {
4384#        debug("pathrestriction $name at $interface->{name}");
4385
59
59
42
80
        push @{ $interface->{path_restrict} }, $restrict;
4386
59
55
        my $router = $interface->{router};
4387
59
110
        $router->{managed} or $router->{semi_managed} = 1;
4388    }
4389
28
30
    push @pathrestrictions, $restrict;
4390
28
29
    return;
4391}
4392
4393sub link_pathrestrictions {
4394
337
0
530
    for my $restrict (values %pathrestrictions) {
4395
29
57
        $restrict->{elements} = expand_group $restrict->{elements},
4396          $restrict->{name};
4397
29
50
        my $changed;
4398
29
30
        my $private = my $no_private = $restrict->{private};
4399
29
29
29
37
        for my $obj (@{ $restrict->{elements} }) {
4400
60
77
            if (not is_interface($obj)) {
4401
0
0
                err_msg("$restrict->{name} must not reference $obj->{name}");
4402
0
0
                $obj     = undef;
4403
0
0
                $changed = 1;
4404
0
0
                next;
4405            }
4406
4407            # Add pathrestriction to interface.
4408            # Multiple restrictions may be applied to a single
4409            # interface.
4410
60
60
51
86
            push @{ $obj->{path_restrict} }, $restrict;
4411
4412            # Unmanaged router with pathrestriction is handled specially.
4413            # It is separating zones, but gets no code.
4414
60
55
            my $router = $obj->{router};
4415
60
97
            $router->{managed} or $router->{semi_managed} = 1;
4416
4417            # Pathrestrictions must not be applied to secondary interfaces
4418
60
87
            $obj->{main_interface}
4419              and err_msg "secondary $obj->{name} must not be used",
4420              " in pathrestriction";
4421
4422            # Private pathrestriction must reference at least one interface
4423            # of its own context.
4424
60
67
            if ($private) {
4425
0
0
                if (my $obj_p = $obj->{private}) {
4426
0
0
                    $private eq $obj_p and $no_private = 0;
4427                }
4428            }
4429
4430            # Public pathrestriction must not reference private interface.
4431            else {
4432
60
119
                if (my $obj_p = $obj->{private}) {
4433
0
0
                    err_msg "Public $restrict->{name} must not reference",
4434                      " $obj_p.private $obj->{name}";
4435                }
4436            }
4437        }
4438
29
45
        if ($no_private) {
4439
0
0
            err_msg "$private.private $restrict->{name} must reference",
4440              " at least one interface out of $private.private";
4441        }
4442
29
45
        if ($changed) {
4443
0
0
0
0
0
0
            $restrict->{elements} = [ grep { $_ } @{ $restrict->{elements} } ];
4444        }
4445
29
29
23
43
        my $count = @{ $restrict->{elements} };
4446
29
64
        if ($count == 1) {
4447
0
0
            warn_msg("Ignoring $restrict->{name} with only",
4448                     " $restrict->{elements}->[0]->{name}");
4449
0
0
            $restrict->{elements} = [];
4450        }
4451        elsif ($count == 0) {
4452
0
0
            warn_msg("Ignoring $restrict->{name} without elements");
4453        }
4454
4455        # Add pathrestriction to tunnel interfaces,
4456        # which belong to real interface.
4457        # Don't count them as extra elements.
4458
29
29
26
40
        for my $interface (@{ $restrict->{elements} }) {
4459
60
231
            next if not($interface->{spoke} or $interface->{hub});
4460
4461            # Don't add for no_check interface because traffic would
4462            # pass the pathrestriction two times.
4463
0
0
            next if $interface->{no_check};
4464
0
0
            my $router = $interface->{router};
4465
0
0
0
0
            for my $intf (@{ $router->{interfaces} }) {
4466
0
0
                my $real_intf = $intf->{real_interface};
4467
0
0
                next if not $real_intf;
4468
0
0
                next if not $real_intf eq $interface;
4469
4470#               debug("Adding $restrict->{name} to $intf->{name}");
4471
0
0
0
0
                push @{ $restrict->{elements} },  $intf;
4472
0
0
0
0
                push @{ $intf->{path_restrict} }, $restrict;
4473            }
4474        }
4475    }
4476
337
307
    return;
4477}
4478
4479# Collect groups of virtual interfaces
4480# - be connected to the same network and
4481# - having the same IP address.
4482# Link all virtual interfaces to the group of member interfaces.
4483# Check consistency:
4484# - Member interfaces must use identical protocol and identical ID.
4485# - The same ID must not be used by some other group
4486#   - connected to the same network
4487#   - emploing the same redundancy type
4488sub link_virtual_interfaces  {
4489
4490    # Collect array of virtual interfaces with same IP at same network.
4491
337
0
291
    my %net2ip2virtual;
4492
4493    # Hash table to look up first virtual interface of a group
4494    # inside the same network and using the same ID and type.
4495    my %net2id2type2virtual;
4496
337
404
    for my $virtual1 (@virtual_interfaces) {
4497
72
110
        next if $virtual1->{disabled};
4498
72
68
        my $ip    = $virtual1->{ip};
4499
72
67
        my $net   = $virtual1->{network};
4500
72
171
        my $type1 = $virtual1->{redundancy_type} || '';
4501
72
173
        my $id1   = $virtual1->{redundancy_id} || '';
4502
72
162
        if (my $interfaces = $net2ip2virtual{$net}->{$ip}) {
4503
37
33
            my $virtual2 = $interfaces->[0];
4504
37
88
            my $type2 = $virtual2->{redundancy_type} || '';
4505
37
53
            if ($type1 ne $type2) {
4506
0
0
                err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}",
4507                  " use different redundancy protocols";
4508
0
0
                next;
4509            }
4510
37
119
            if (not $id1 eq ($virtual2->{redundancy_id} || '')) {
4511
0
0
                err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}",
4512                  " use different ID";
4513
0
0
                next;
4514            }
4515
4516            # This changes value of %net2ip2virtual and all attributes
4517            # {redundancy_interfaces} where this array is referenced.
4518
37
39
            push @$interfaces, $virtual1;
4519
37
71
            $virtual1->{redundancy_interfaces} = $interfaces;
4520        }
4521        else {
4522
35
83
            $net2ip2virtual{$net}->{$ip} = $virtual1->{redundancy_interfaces} =
4523              [$virtual1];
4524
4525            # Check for identical ID used at unrelated virtual interfaces
4526            # inside the same network.
4527
35
81
            if ($id1) {
4528
0
0
                if (my $virtual2 =
4529                    $net2id2type2virtual{$net}->{$id1}->{$type1})
4530                {
4531
0
0
                    err_msg "Virtual IP:",
4532                      " Unrelated $virtual1->{name} and $virtual2->{name}",
4533                      " use identical ID";
4534                }
4535                else {
4536
0
0
                    $net2id2type2virtual{$net}->{$id1}->{$type1} = $virtual1;
4537                }
4538            }
4539        }
4540    }
4541
4542
4543    # A virtual interface is used as hop for static routing.
4544    # Therefore a network behind this interface must be reachable
4545    # via all virtual interfaces of the group.
4546    # This can only be guaranteed, if pathrestrictions are identical
4547    # at all interfaces.
4548    # Exception in routing code:
4549    # If the group has ony two interfaces, the one or other physical
4550    # interface can be used as hop.
4551
337
306
    my %seen;
4552
337
516
    for my $href (values %net2ip2virtual) {
4553
35
54
        for my $interfaces (values %$href) {
4554
35
85
            next if @$interfaces <= 2;
4555
4
14
7
19
            my @virt_routers = map { $_->{router} } @$interfaces;
4556
4
14
6
27
            my %routers_hash = map { $_ => $_ } @virt_routers;
4557
4
6
            for my $router (@virt_routers) {
4558
14
14
12
16
                for my $interface (@{ $router->{interfaces} }) {
4559
55
89
                    next if $interface->{main_interface};
4560
33
54
                    my $restricts = $interface->{path_restrict} or next;
4561
2
2
                    for my $restrict (@$restricts) {
4562
2
6
                        next if $seen{$restrict};
4563
2
4
                        my @restrict_routers =
4564
2
3
                            grep({ $routers_hash{$_} }
4565
1
2
                                 map { $_->{router} }
4566
1
1
                                 @{ $restrict->{elements} });
4567
1
2
                        next if @restrict_routers == @virt_routers;
4568
1
3
                        $seen{$restrict} = 1;
4569
1
1
                        my @info;
4570
1
1
                        for my $router (@virt_routers) {
4571
3
3
                            my $info = $router->{name};
4572
3
6
2
15
                            if (grep { $_ eq $router} @restrict_routers) {
4573
1
2
                                $info .= " has $restrict->{name}";
4574                            }
4575
3
4
                            push @info, $info;
4576                        }
4577
1
4
                        err_msg("Must apply pathrestriction equally to",
4578                                " group of routers with virtual IP:\n",
4579                                " - ",
4580                                join("\n - ", @info));
4581                    }
4582                }
4583            }
4584        }
4585    }
4586
4587    # Automatically add pathrestriction to interfaces belonging to
4588    # $net2ip2virtual, if at least one interface is managed.
4589    # Pathrestriction would be useless if all devices are unmanaged.
4590
337
494
    for my $href (values %net2ip2virtual) {
4591
35
39
        for my $interfaces (values %$href) {
4592
35
35
            for my $interface (@$interfaces) {
4593
42
38
                my $router = $interface->{router};
4594
42
127
                if ($router->{managed} || $router->{routing_only}) {
4595
28
46
                    my $name = "auto-virtual-" . print_ip $interface->{ip};
4596
28
45
                    add_pathrestriction($name, $interfaces);
4597
28
57
                    last;
4598                }
4599            }
4600        }
4601    }
4602
337
514
    return;
4603}
4604
4605sub check_ip_addresses {
4606
337
0
500
    for my $network (values %networks) {
4607
1115
11
2354
29
        if (    $network->{ip} eq 'unnumbered'
4608            and $network->{interfaces}
4609            and @{ $network->{interfaces} } > 2)
4610        {
4611
0
0
            my $msg = "Unnumbered $network->{name} is connected to"
4612              . " more than two interfaces:";
4613
0
0
0
0
            for my $interface (@{ $network->{interfaces} }) {
4614
0
0
                $msg .= "\n $interface->{name}";
4615            }
4616
0
0
            err_msg($msg);
4617        }
4618
4619
1115
835
        my %ip2obj;
4620
4621        # 1. Check for duplicate interface addresses.
4622        # 2. Short interfaces must not be used, if a managed interface
4623        #    with static routing exists in the same network.
4624
1115
801
        my ($short_intf, $route_intf);
4625
1115
1115
835
1362
        for my $interface (@{ $network->{interfaces} }) {
4626
1633
1545
            my $ip = $interface->{ip};
4627
1633
1872
            if ($ip eq 'short') {
4628
4629                # Ignore short interface from splitted crypto router.
4630
223
223
179
413
                if (1 < @{ $interface->{router}->{interfaces} }) {
4631
208
183
                    $short_intf = $interface;
4632                }
4633            }
4634            else {
4635
1410
2724
                unless ($ip =~ /^(?:unnumbered|negotiated|tunnel|bridged)$/) {
4636
1330
1137
                    my $router = $interface->{router};
4637
1330
4772
                    if (($router->{managed} || $router->{routing_only})
4638                        && !$interface->{routing})
4639                    {
4640
713
606
                        $route_intf = $interface;
4641                    }
4642
1330
1750
                    if (my $old_intf = $ip2obj{$ip}) {
4643
39
140
                        unless ($old_intf->{redundant}
4644                            and $interface->{redundant})
4645                        {
4646
2
9
                            err_msg "Duplicate IP address for",
4647                              " $old_intf->{name} and $interface->{name}";
4648                        }
4649                    }
4650                    else {
4651
1291
1887
                        $ip2obj{$ip} = $interface;
4652                    }
4653                }
4654            }
4655
1633
3748
            if ($short_intf and $route_intf) {
4656
1
6
                err_msg "$short_intf->{name} must be defined in more detail,",
4657                  " since there is\n",
4658                  " a managed $route_intf->{name} with static routing enabled.";
4659            }
4660        }
4661
1115
1022
        my %range2obj;
4662
1115
1115
795
1427
        for my $host (@{ $network->{hosts} }) {
4663
181
331
            if (my $ip = $host->{ip}) {
4664
160
272
                if (my $other_device = $ip2obj{$ip}) {
4665
4
15
                    err_msg "Duplicate IP address for $other_device->{name}",
4666                      " and $host->{name}";
4667                }
4668                else {
4669
156
288
                    $ip2obj{$ip} = $host;
4670                }
4671            }
4672            elsif (my $range = $host->{range}) {
4673
21
24
                my ($from, $to) = @$range;
4674
21
57
                if (my $other_device = $range2obj{$from}->{$to}) {
4675
1
4
                    err_msg "Duplicate IP range for $other_device->{name}",
4676                      " and $host->{name}";
4677                }
4678                else {
4679
20
41
                    $range2obj{$from}->{$to} = $host;
4680                }
4681            }
4682        }
4683
1115
1115
878
2075
        for my $host (@{ $network->{hosts} }) {
4684
181
535
            if (my $range = $host->{range}) {
4685
21
39
                for (my $ip = $range->[0] ; $ip <= $range->[1] ; $ip++) {
4686
774
1615
                    if (my $other_device = $ip2obj{$ip}) {
4687
5
6
                        is_host($other_device)
4688                          or err_msg("Duplicate IP address for",
4689                                     " $other_device->{name}",
4690                                     " and $host->{name}");
4691                    }
4692                }
4693            }
4694        }
4695    }
4696
337
357
    return;
4697}
4698
4699sub link_ipsec;
4700sub link_crypto;
4701sub link_tunnels;
4702
4703sub link_topology {
4704
337
0
474
    progress('Linking topology');
4705
337
465
    link_routers;
4706
337
487
    link_ipsec;
4707
337
459
    link_crypto;
4708
337
455
    link_tunnels;
4709
337
476
    link_pathrestrictions;
4710
337
435
    link_virtual_interfaces;
4711
337
452
    link_areas;
4712
337
445
    link_subnets;
4713
337
478
    link_owners;
4714
337
439
    check_ip_addresses();
4715
337
302
    return;
4716}
4717
4718####################################################################
4719# Mark all parts of the topology located behind disabled interfaces.
4720# "Behind" is defined like this:
4721# Look from a router to its interfaces;
4722# if an interface is marked as disabled,
4723# recursively mark the whole part of the topology located behind
4724# this interface as disabled.
4725# Be cautious with loops:
4726# Mark all interfaces at loop entry as disabled,
4727# otherwise the whole topology will get disabled.
4728####################################################################
4729
4730sub disable_behind;
4731
4732sub disable_behind {
4733
3
0
3
    my ($in_interface) = @_;
4734
4735#  debug("disable_behind $in_interface->{name}");
4736
3
5
    $in_interface->{disabled} = 1;
4737
3
2
    my $network = $in_interface->{network};
4738
3
13
    if (not $network or $network->{disabled}) {
4739
4740#      debug("Stop disabling at $network->{name}");
4741
1
2
        return;
4742    }
4743
2
3
    $network->{disabled} = 1;
4744
2
2
3
3
    for my $host (@{ $network->{hosts} }) {
4745
1
2
        $host->{disabled} = 1;
4746    }
4747
2
2
2
4
    for my $interface (@{ $network->{interfaces} }) {
4748
3
8
        next if $interface eq $in_interface;
4749
4750        # This stops at other entry of a loop as well.
4751
1
2
        if ($interface->{disabled}) {
4752
4753#        debug("Stop disabling at $interface->{name}");
4754
1
2
            next;
4755        }
4756
0
0
        $interface->{disabled} = 1;
4757
0
0
        my $router = $interface->{router};
4758
0
0
        $router->{disabled} = 1;
4759
0
0
0
0
        for my $out_interface (@{ $router->{interfaces} }) {
4760
0
0
            next if $out_interface eq $interface;
4761
0
0
            disable_behind $out_interface ;
4762        }
4763    }
4764
2
3
    return;
4765}
4766
4767# Lists of network objects which are left over after disabling.
4768#my @managed_routers;   # defined above
4769my @routing_only_routers;
4770my @managed_crypto_hubs;
4771my @routers;
4772my @networks;
4773my @zones;
4774my @areas;
4775
4776# Group bridged networks by prefix of name.
4777# Each group
4778# - must have the same IP address and mask,
4779# - must have at least two members,
4780# - must be adjacent
4781# - linked by bridged interfaces
4782# - IP addresses of hosts must be disjoint (ToDo).
4783# Each router having a bridged interface
4784# must connect at least two bridged networks of the same group.
4785sub check_bridged_networks {
4786
337
0
290
    my %prefix2net;
4787
337
366
    for my $network (@networks) {
4788
1112
1902
        my $prefix = $network->{bridged} or next;
4789
14
32
        $prefix2net{$prefix}->{$network} = $network;
4790    }
4791
337
593
    for my $prefix (keys %prefix2net) {
4792
7
20
        if (my $network = $networks{$prefix}) {
4793
0
0
            $network->{disabled}
4794              or err_msg("Must not define $network->{name} together with",
4795                " bridged networks of same name");
4796        }
4797    }
4798
337
499
    for my $href (values %prefix2net) {
4799
7
13
        my @group = values %$href;
4800
7
8
        my $net1  = pop(@group);
4801
7
11
        @group or warn_msg("Bridged $net1->{name} must not be used solitary");
4802
7
8
        my %seen;
4803
7
8
        my @next = ($net1);
4804
7
7
6
14
        my ($ip1, $mask1) = @{$net1}{qw(ip mask)};
4805
4806        # Mark all networks connected directly or indirectly with $net1
4807        # by a bridge as 'connected' in $href.
4808
7
14
        while (my $network = pop(@next)) {
4809
14
14
14
17
            my ($ip, $mask) = @{$network}{qw(ip mask)};
4810
14
46
            $ip == $ip1 and $mask == $mask1
4811              or err_msg("$net1->{name} and $network->{name} must have",
4812                " identical ip/mask");
4813
14
23
            $href->{$network} = 'connected';
4814
14
14
9
18
            for my $in_intf (@{ $network->{interfaces} }) {
4815
24
54
                next if $in_intf->{ip} ne 'bridged';
4816
14
13
                my $router = $in_intf->{router};
4817
14
39
                next if $seen{$router};
4818
7
4
                my $count = 1;
4819
7
12
                $seen{$router} = $router;
4820
7
13
                if (my $layer3_intf = $in_intf->{layer3_interface}) {
4821
7
14
                    match_ip($layer3_intf->{ip}, $ip, $mask)
4822                      or err_msg("$layer3_intf->{name}'s IP doesn't match",
4823                        " IP/mask of bridged networks");
4824                }
4825
7
7
7
12
                for my $out_intf (@{ $router->{interfaces} }) {
4826
21
41
                    next if $out_intf eq $in_intf;
4827
14
26
                    next if $out_intf->{ip} ne 'bridged';
4828
7
9
                    my $next_net = $out_intf->{network};
4829
7
13
                    next if not $href->{$next_net};
4830
7
7
                    push(@next, $out_intf->{network});
4831
7
14
                    $count++;
4832                }
4833
7
23
                $count > 1
4834                  or err_msg("$router->{name} can't bridge a single network");
4835            }
4836        }
4837
7
7
        for my $network (@group) {
4838
7
31
            $href->{$network} eq 'connected'
4839              or err_msg(
4840                "$network->{name} and $net1->{name}",
4841                " must be connected by bridge"
4842              );
4843        }
4844    }
4845
337
434
    return;
4846}
4847
4848sub mark_disabled {
4849
337
1585
0
560
1749
    my @disabled_interfaces = grep { $_->{disabled} } values %interfaces;
4850
4851
337
417
    for my $interface (@disabled_interfaces) {
4852
3
7
        next if $interface->{router}->{disabled};
4853
3
6
        disable_behind($interface);
4854
3
8
        if ($interface->{router}->{disabled}) {
4855
4856            # We reached an initial element of @disabled_interfaces,
4857            # which seems to be part of a loop.
4858            # This is dangerous, since the whole topology
4859            # may be disabled by accident.
4860
0
0
            err_msg "$interface->{name} must not be disabled,\n",
4861              " since it is part of a loop";
4862        }
4863    }
4864
337
401
    for my $interface (@disabled_interfaces) {
4865
4866        # Delete disabled interfaces from routers.
4867
3
4
        my $router = $interface->{router};
4868
3
5
        aref_delete($router->{interfaces}, $interface);
4869
3
8
        if ($router->{managed} || $router->{routing_only}) {
4870
3
5
            aref_delete($interface->{hardware}->{interfaces}, $interface);
4871        }
4872    }
4873
4874    # Disable area, where all interfaces or anchor are disabled.
4875
337
790
    for my $area (sort by_name values %areas) {
4876
66
61
        my $ok;
4877
66
116
        if (my $anchor = $area->{anchor}) {
4878
17
23
            $ok = !$anchor->{disabled};
4879        }
4880        else {
4881
49
58
            for my $attr (qw(border inclusive_border)) {
4882
98
206
                my $borders = $area->{$attr} or next;
4883
52
62
70
163
                if (my @active_borders = grep { !$_->{disabled} } @$borders) {
4884
52
65
                    $area->{$attr} = \@active_borders;
4885
52
75
                    $ok = 1;
4886                }
4887            }
4888        }
4889
66
108
        if ($ok) {
4890
66
109
            push @areas, $area;
4891        }
4892        else {
4893
0
0
            $area->{disabled} = 1;
4894        }
4895    }
4896
4897
337
735
    for my $router (sort(by_name values %routers), @router_fragments) {
4898
690
1080
        next if $router->{disabled};
4899
690
602
        push @routers, $router;
4900
690
1152
        if ($router->{managed}) {
4901
465
581
            push @managed_routers, $router;
4902        }
4903        elsif ($router->{routing_only}) {
4904
6
8
            push @routing_only_routers, $router;
4905        }
4906    }
4907
4908    # Collect vrf instances belonging to one device.
4909    # This includes different managed hosts with identical server_name.
4910
337
318
    my %name2vrf;
4911
337
395
    for my $router (@managed_routers, @routing_only_routers) {
4912
491
751
        next if $router->{orig_router};
4913
473
497
        my $device_name = $router->{device_name};
4914
473
473
351
1026
        push @{ $name2vrf{$device_name} }, $router;
4915    }        
4916
337
507
    for my $aref (values %name2vrf) {
4917
469
899
        next if @$aref == 1;
4918
4
8
5
34
        equal(map {  $_->{managed} || $_->{routing_only}
4919                   ? $_->{model}->{name}
4920                   : () }
4921              @$aref)
4922          or err_msg("All VRF instances of router:$aref->[0]->{device_name}",
4923                     " must have identical model");
4924
4925
4
7
        my %hardware;
4926
4
5
        for my $router (@$aref) {
4927
8
8
6
11
            for my $hardware (@{ $router->{hardware} }) {
4928
14
17
                my $name = $hardware->{name};
4929
14
19
                if (my $other = $hardware{$name}) {
4930
0
0
                    err_msg(
4931                        "Duplicate hardware '$name' at",
4932                        " $other->{name} and $router->{name}"
4933                    );
4934                }
4935                else {
4936
14
28
                    $hardware{$name} = $router;
4937                }
4938            }
4939        }
4940
4
6
        my $shared_hash = {};
4941
4
8
        for my $router (@$aref) {
4942
8
9
            $router->{vrf_members} = $aref;
4943
8
16
            $router->{vrf_shared_data} = $shared_hash;
4944        }
4945    }
4946
4947    # Collect networks into @networks.
4948    # We need a deterministic order.
4949    # Don't sort by name because code shouldn't change if a network is renamed.
4950    # Derive order from order of routers and interfaces.
4951
337
304
    my %seen;
4952
337
353
    for my $router (@routers) {
4953
690
690
530
848
        for my $interface (@{ $router->{interfaces} }) {
4954
1610
2175
            next if $interface->{disabled};
4955
1610
1323
            my $network = $interface->{network};
4956
1610
4425
            $seen{$network}++ or push @networks, $network;
4957        }
4958    }
4959
4960    # Find networks not connected to any router.
4961
337
533
    for my $network (values %networks) {
4962
1115
1508
        next if $network->{disabled};
4963
1113
2180
        if (! $seen{$network}) {
4964
20
36
            if (keys %networks > 1) {
4965
1
3
                err_msg("$network->{name} isn't connected to any router");
4966
1
3
                $network->{disabled} = 1;
4967            }
4968            else {
4969
19
35
                push @networks, $network;
4970            }
4971        }
4972    }
4973
4974
337
72
446
112
    @virtual_interfaces = grep { not $_->{disabled} } @virtual_interfaces;
4975
337
476
    check_bridged_networks();
4976
337
702
    return;
4977}
4978
4979####################################################################
4980# Convert hosts to subnets.
4981# Find adjacent subnets.
4982# Mark subnet relation of subnets.
4983####################################################################
4984
4985# 255.255.255.255, 127.255.255.255, ..., 0.0.0.3, 0.0.0.1, 0.0.0.0
4986my @inverse_masks = map { complement_32bit prefix2mask $_ } (0 .. 32);
4987
4988# Convert an IP range to a set of covering IP/mask pairs.
4989sub split_ip_range {
4990
21
0
20
    my ($low, $high) = @_;
4991
21
19
    my @result;
4992  IP:
4993
21
34
    while ($low <= $high) {
4994
39
41
        for my $mask (@inverse_masks) {
4995
1200
1916
            if (($low & $mask) == 0 && ($low + $mask) <= $high) {
4996
39
51
                push @result, [ $low, complement_32bit $mask ];
4997
39
37
                $low = $low + $mask + 1;
4998
39
72
                next IP;
4999            }
5000        }
5001    }
5002
21
35
    return @result;
5003}
5004
5005sub convert_hosts {
5006
321
0
415
    progress('Converting hosts to subnets');
5007
321
361
    for my $network (@networks) {
5008
1180
2506
        next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/;
5009
1147
819
        my @inv_prefix_aref;
5010
5011        # Converts hosts and ranges to subnets.
5012        # Eliminate duplicate subnets.
5013
1147
1147
858
1496
        for my $host (@{ $network->{hosts} }) {
5014
174
313
            my ($name, $nat, $id, $private, $owner) =
5015
174
184
              @{$host}{qw(name nat id private owner)};
5016
174
159
            my @ip_mask;
5017
174
312
            if (my $ip = $host->{ip}) {
5018
153
246
                @ip_mask = [ $ip, 0xffffffff ];
5019
153
264
                if ($id) {
5020
15
78
                    if (my ($user, $dom) = ($id =~ /^(.*?)(\@.*)$/)) {
5021
14
36
                        $user or err_msg("ID of $name must not start",
5022                                         " with character '\@'");
5023                    }
5024                    else {
5025
1
3
                        err_msg("ID of $name must contain character '\@'");
5026                    }
5027                }
5028            }
5029            elsif ($host->{range}) {
5030
21
21
21
28
                my ($ip1, $ip2) = @{ $host->{range} };
5031
21
36
                @ip_mask = split_ip_range $ip1, $ip2;
5032
21
39
                if ($id) {
5033
11
40
                    if (@ip_mask > 1) {
5034
1
4
                        err_msg("Range of $name with ID must expand to",
5035                                " exactly one subnet");
5036                    }
5037                    elsif ($ip_mask[0]->[1] == 0xffffffff) {
5038
1
3
                        err_msg("$name with ID must not have single IP");
5039                    }
5040                    elsif ($id =~ /^.+\@/) {
5041
1
3
                        err_msg("ID of $name must start with character '\@'",
5042                                " or have no '\@' at all");
5043                    }
5044                }
5045            }
5046            else {
5047
0
0
                internal_err("unexpected host type");
5048            }
5049
174
199
            for my $ip_mask (@ip_mask) {
5050
192
213
                my ($ip, $mask) = @$ip_mask;
5051
192
257
                my $inv_prefix = 32 - mask2prefix $mask;
5052
192
417
                if (my $other_subnet = $inv_prefix_aref[$inv_prefix]->{$ip}) {
5053
4
7
                    my $nat2 = $other_subnet->{nat};
5054
4
2
                    my $nat_error;
5055
4
33
                    if ($nat xor $nat2) {
5056
0
0
                        $nat_error = 1;
5057                    }
5058                    elsif ($nat and $nat2) {
5059
5060                        # Number of entries is equal.
5061
0
0
                        if (keys %$nat == keys %$nat2) {
5062
5063                            # Entries are equal.
5064
0
0
                            for my $name (keys %$nat) {
5065
0
0
                                unless ($nat2->{$name}
5066                                    and $nat->{$name} eq $nat2->{$name})
5067                                {
5068
0
0
                                    $nat_error = 1;
5069
0
0
                                    last;
5070                                }
5071                            }
5072                        }
5073                        else {
5074
0
0
                            $nat_error = 1;
5075                        }
5076                    }
5077                    $nat_error
5078
4
7
                      and err_msg "Inconsistent NAT definition for",
5079                      " $other_subnet->{name} and $host->{name}";
5080
5081
4
4
                    my $owner2 = $other_subnet->{owner};
5082
4
21
                    if (($owner xor $owner2)
5083                        || $owner && $owner2 && $owner ne $owner2)
5084                    {
5085
0
0
                        err_msg "Inconsistent owner definition for",
5086                          " $other_subnet->{name} and $host->{name}";
5087                    }
5088
4
4
3
15
                    push @{ $host->{subnets} }, $other_subnet;
5089                }
5090                else {
5091
188
287
                    my $subnet = new(
5092                        'Subnet',
5093                        name    => $name,
5094                        network => $network,
5095                        ip      => $ip,
5096                        mask    => $mask,
5097                    );
5098
188
301
                    $subnet->{nat}     = $nat     if $nat;
5099
188
266
                    $subnet->{private} = $private if $private;
5100
188
274
                    $subnet->{owner}   = $owner   if $owner;
5101
188
260
                    if ($id) {
5102
30
32
                        $subnet->{id} = $id;
5103
30
37
                        $subnet->{radius_attributes} =
5104                          $host->{radius_attributes};
5105                    }
5106
188
264
                    $inv_prefix_aref[$inv_prefix]->{$ip} = $subnet;
5107
188
188
151
288
                    push @{ $host->{subnets} },    $subnet;
5108
188
188
162
594
                    push @{ $network->{subnets} }, $subnet;
5109                }
5110            }
5111        }
5112
5113        # Find adjacent subnets which build a larger subnet.
5114
1147
1563
        my $network_inv_prefix = 32 - mask2prefix $network->{mask};
5115
1147
1981
        for (my $i = 0 ; $i < @inv_prefix_aref ; $i++) {
5116
189
346
            if (my $ip2subnet = $inv_prefix_aref[$i]) {
5117
163
205
                my $next   = 2**$i;
5118
163
225
                my $modulo = 2 * $next;
5119
163
306
                for my $ip (keys %$ip2subnet) {
5120
196
189
                    my $subnet = $ip2subnet->{$ip};
5121
5122
196
1100
                    if (
5123
5124                        # Don't combine subnets with NAT
5125                        # ToDo: This would be possible if all NAT addresses
5126                        #  match too.
5127                        # But, attention for PIX firewalls:
5128                        # static commands for networks / subnets block
5129                        # network and broadcast address.
5130                        not $subnet->{nat}
5131
5132                        # Don't combine subnets having radius-ID.
5133                        and not $subnet->{id}
5134
5135                        # Only take the left part of two adjacent subnets.
5136                        and $ip % $modulo == 0
5137                      )
5138                    {
5139
101
101
                        my $next_ip = $ip + $next;
5140
5141                        # Find the right part.
5142
101
216
                        if (my $neighbor = $ip2subnet->{$next_ip}) {
5143
8
11
                            $subnet->{neighbor} = $neighbor;
5144
8
8
                            my $up_inv_prefix = $i + 1;
5145
8
6
                            my $up;
5146
8
35
                            if ($up_inv_prefix >= $network_inv_prefix) {
5147
5148                                # Larger subnet is whole network.
5149
0
0
                                $up = $network;
5150                            }
5151                            elsif ( $up_inv_prefix < @inv_prefix_aref
5152                                and $up =
5153                                $inv_prefix_aref[$up_inv_prefix]->{$ip})
5154                            {
5155                            }
5156                            else {
5157
8
41
                                (my $name = $subnet->{name}) =~
5158                                  s/^.*:/auto_subnet:/;
5159
8
17
                                my $mask = prefix2mask(32 - $up_inv_prefix);
5160
8
74
                                $up = new(
5161                                    'Subnet',
5162                                    name    => $name,
5163                                    network => $network,
5164                                    ip      => $ip,
5165                                    mask    => $mask
5166                                );
5167
8
18
                                if (my $private = $subnet->{private}) {
5168
0
0
                                    $up->{private} = $private if $private;
5169                                }
5170
8
16
                                $inv_prefix_aref[$up_inv_prefix]->{$ip} = $up;
5171                            }
5172
8
9
                            $subnet->{up}   = $up;
5173
8
8
                            $neighbor->{up} = $up;
5174
8
8
9
11
                            push @{ $network->{subnets} }, $up;
5175
5176                            # Don't search for enclosing subnet below.
5177
8
15
                            next;
5178                        }
5179                    }
5180
5181                    # For neighbors, {up} has been set already.
5182
188
299
                    next if $subnet->{up};
5183
5184                    # Search for enclosing subnet.
5185
183
370
                    for (my $j = $i + 1 ; $j < @inv_prefix_aref ; $j++) {
5186
52
63
                        my $mask = prefix2mask(32 - $j);
5187
52
56
                        $ip = $ip & $mask;    # Perl bug #108480
5188
52
129
                        if (my $up = $inv_prefix_aref[$j]->{$ip}) {
5189
7
9
                            $subnet->{up} = $up;
5190
7
6
                            last;
5191                        }
5192                    }
5193
5194                    # Use network, if no enclosing subnet found.
5195
183
862
                    $subnet->{up} ||= $network;
5196                }
5197            }
5198        }
5199
5200        # Attribute {up} has been set for all subnets now.
5201        # Do the same for interfaces.
5202
1147
1147
892
1497
        for my $interface (@{ $network->{interfaces} }) {
5203
1497
2759
            $interface->{up} = $network;
5204        }
5205    }
5206
321
351
    return;
5207}
5208
5209# Find adjacent subnets and substitute them by their enclosing subnet.
5210sub combine_subnets  {
5211
596
0
526
    my ($subnets) = @_;
5212
596
102
729
245
    my %hash = map { $_ => $_ } @$subnets;
5213
596
447
    my @extra;
5214
596
459
    while(1) {
5215
600
667
        for my $subnet (@$subnets) {
5216
148
98
            my $neighbor;
5217
148
390
            if ($neighbor = $subnet->{neighbor} and $hash{$neighbor}) {
5218
5
3
                my $up = $subnet->{up};
5219
5
10
                unless ($hash{$up}) {
5220
5
6
                    $hash{$up} = $up;
5221
5
6
                    push @extra, $up;
5222                }
5223
5
6
                delete $hash{$subnet};
5224
5
8
                delete $hash{$neighbor};
5225            }
5226        }
5227
600
749
        if (@extra) {
5228
5229            # Try again to combine subnets with extra subnets.
5230            # This version isn't optimized.
5231
4
7
            push @$subnets, @extra;
5232
4
4
            @extra = ();
5233        }
5234        else {
5235
596
542
            last;
5236        }
5237    }
5238
5239    # Sort networks by size of mask,
5240    # i.e. large subnets coming first and
5241    # for equal mask by IP address.
5242    # We need this to make the output deterministic.
5243
596
23
1277
133
    return [ sort { $a->{mask} <=> $b->{mask} || $a->{ip} <=> $b->{ip} }
5244          values %hash ];
5245}
5246
5247####################################################################
5248# Expand rules
5249#
5250# Simplify rules to expanded rules where each rule has exactly one
5251# src, dst and prt
5252####################################################################
5253
5254my %name2object = (
5255    host      => \%hosts,
5256    network   => \%networks,
5257    interface => \%interfaces,
5258    any       => \%aggregates,
5259    group     => \%groups,
5260    area      => \%areas,
5261);
5262
5263sub get_intf  {
5264
71
0
65
    my ($router) = @_;
5265
71
165
    if (my $orig_router = $router->{orig_router}) {
5266
0
0
0
0
        return @{ $orig_router->{orig_interfaces} };
5267    }
5268    elsif (my $orig_interfaces = $router->{orig_interfaces}) {
5269
10
21
        return @$orig_interfaces;
5270    }
5271    else {
5272
61
61
43
144
        return @{ $router->{interfaces} };
5273    }
5274}
5275
5276my %auto_interfaces;
5277
5278sub get_auto_intf {
5279
49
0
41
    my ($object, $managed) = @_;
5280
49
126
    $managed ||= 0;
5281
49
85
    my $result = $auto_interfaces{$object}->{$managed};
5282
49
76
    if (not $result) {
5283
23
16
        my $name;
5284
23
27
        if (is_router $object) {
5285
17
70
            ($name = $object->{name}) =~ s/^router://;
5286        }
5287        else {
5288
6
13
            $name = "[$object->{name}]";
5289        }
5290
23
55
        $name   = "interface:$name.[auto]";
5291
23
35
        $result = new(
5292            'Autointerface',
5293            name    => $name,
5294            object  => $object,
5295            managed => $managed
5296        );
5297
23
36
        $result->{disabled} = 1 if $object->{disabled};
5298
23
46
        $auto_interfaces{$object}->{$managed} = $result;
5299
5300#       debug($result->{name});
5301    }
5302
49
109
    return $result;
5303}
5304
5305# Check intersection of interface and auto-interface.
5306# Prevent expressions like "interface:r.x &! interface:r.[auto]",
5307# because we don't know the exact value of the auto-interface.
5308# The auto-interface could be "r.x" but not for sure.
5309# $info is hash with attributes
5310# - i => { $router => $interface, ... }
5311# - r => { $router => $autointerface, ... }
5312# - n => { $router => { $network => autointerface, ... }, ... }
5313#
5314# interface:router.network conflicts with interface:router.[auto]
5315# interface:router.network conflicts with interface:[network].[auto]
5316# interface:router:[auto] conflicts with interface:[network].[auto]
5317#  if router is connected to network.
5318sub check_auto_intf {
5319
28
0
33
    my ($info, $elements, $context) = @_;
5320
28
27
    my $add_info = {};
5321
5322    # Check current elements with interfaces of previous elements.
5323
28
32
    for my $obj (@$elements) {
5324
37
37
        my $type = ref $obj;
5325
37
23
        my $other;
5326
37
70
        if ($type eq 'Interface') {
5327
10
9
            my $router = $obj->{router};
5328
10
10
            my $network = $obj->{network};
5329
10
42
            $other = $info->{r}->{$router} || $info->{n}->{$router}->{$network};
5330
10
21
            $add_info->{i}->{$router} = $obj;
5331        }
5332        elsif ($type eq 'Autointerface') {
5333
14
13
            my $auto = $obj->{object};
5334
14
15
            if (is_router($auto)) {
5335
6
5
                my $router = $auto;
5336
6
10
                $other = $info->{i}->{$router};
5337
6
9
                if (!$other) {
5338
6
9
                    my $href = $info->{n}->{$router};
5339
6
13
                    $other = (values %$href)[0];
5340                }
5341
6
12
                $add_info->{r}->{$router} = $obj;
5342            }
5343            else {
5344
8
8
                my $network = $auto;
5345
8
8
7
10
                for my $interface (@{ $network->{interfaces} }) {
5346
8
7
                    my $router = $interface->{router};
5347
8
11
                    $other = $info->{r}->{$router};
5348
8
32
                    if (!$other && ($other = $info->{i}->{$router})) {
5349
0
0
                        if (!$other->{network} eq $network) {
5350
0
0
                            $other = undef;
5351                        }
5352                    }
5353
8
26
                    $add_info->{n}->{$router}->{$network} = $obj;
5354                }
5355            }                
5356        }
5357
37
78
        if ($other) {
5358
6
22
            err_msg("Must not use $other->{name} and $obj->{name} together\n",
5359                    " in intersection of $context");
5360        }
5361    }
5362
5363    # Extend info with values of current elements.
5364
28
51
    for my $key (keys %$add_info) {
5365
24
21
        my $href = $add_info->{$key};
5366
24
37
        for my $rkey (%$href) {
5367
48
46
            my $val = $href->{$rkey};
5368
48
61
            if (ref $val) {
5369
24
24
49
96
                @{$info->{$key}->{$rkey}}{keys %$val} = values %$val;
5370            }
5371            else {
5372
24
66
                $info->{$key}->{$rkey} = $val;
5373            }
5374        }
5375    }
5376
28
55
    return;
5377}
5378
5379# Get a reference to an array of network object descriptions and
5380# return a reference to an array of network objects.
5381sub expand_group1;
5382
5383sub expand_group1 {
5384
1763
0
1668
    my ($aref, $context, $clean_autogrp) = @_;
5385
1763
1316
    my @objects;
5386
1763
1752
    for my $parts (@$aref) {
5387
5388
2017
2328
        my ($type, $name, $ext) = @$parts;
5389
2017
7158
        if ($type eq '&') {
5390
14
13
            my @non_compl;
5391            my @compl;
5392
0
0
            my %autointf_info;
5393
14
17
            for my $element (@$name) {
5394
28
40
                my $element1 = $element->[0] eq '!' ? $element->[1] : $element;
5395
37
40
                my @elements =
5396
37
28
61
95
                  map { $_->{is_used} = 1; $_; } @{
5397
28
26
                    expand_group1(
5398                        [$element1], "intersection of $context",
5399                        $clean_autogrp
5400                    )
5401                  };
5402
28
54
                check_auto_intf(\%autointf_info, \@elements, $context);
5403
28
50
                if ($element->[0] eq '!') {
5404
13
22
                    push @compl, @elements;
5405                }
5406                else {
5407
15
23
                    push @non_compl, \@elements;
5408                }
5409            }
5410
14
27
            @non_compl >= 1
5411              or err_msg "Intersection needs at least one element",
5412              " which is not complement in $context";
5413
14
14
            my $result;
5414
14
16
            my $first_set = shift @non_compl;
5415
14
17
            for my $element (@$first_set) {
5416
22
45
                $result->{$element} = $element;
5417            }
5418
14
17
            for my $set (@non_compl) {
5419
1
1
                my $intersection;
5420
1
1
                for my $element (@$set) {
5421
2
5
                    if ($result->{$element}) {
5422
1
2
                        $intersection->{$element} = $element;
5423                    }
5424                }
5425
1
2
                $result = $intersection;
5426            }
5427
14
16
            for my $element (@compl) {
5428
13
23
                next if $element->{disabled};
5429
13
48
                delete $result->{$element}
5430                  or warn_msg("Useless delete of $element->{name} in $context");
5431            }
5432
5433            # Put result into same order as the elements of first non
5434            # complemented set. This set contains all elements of resulting set,
5435            # because we are doing intersection here.
5436
14
22
17
99
            push @objects, grep { $result->{$_} } @$first_set;
5437        }
5438        elsif ($type eq '!') {
5439
0
0
            err_msg("Complement (!) is only supported as part of intersection",
5440                    " in $context");
5441        }
5442        elsif ($type eq 'user') {
5443
5444            # Either a single object or an array of objects.
5445
308
308
            my $elements = $name->{elements};
5446
308
836
            push @objects, ref($elements) eq 'ARRAY' ? @$elements : $elements;
5447        }
5448        elsif ($type eq 'interface') {
5449
266
212
            my @check;
5450
266
824
            if (ref $name) {
5451
18
29
                ref $ext
5452                  or err_msg("Must not use interface:[..].$ext in $context");
5453
18
20
                my ($selector, $managed) = @$ext;
5454
18
101
                my $sub_objects = expand_group1 $name,
5455                  "interface:[..].[$selector] of $context";
5456
18
27
                for my $object (@$sub_objects) {
5457
18
29
                    next if $object->{disabled};
5458
18
19
                    $object->{is_used} = 1;
5459
18
19
                    my $type = ref $object;
5460
18
31
                    if ($type eq 'Network') {
5461
12
13
                        if ($selector eq 'all') {
5462
0
0
                            if ($object->{is_aggregate}) {
5463
5464                                # We can't simply take
5465                                # aggregate -> networks -> interfaces,
5466                                # because subnets may be missing.
5467
0
0
                                $object->{mask} == 0
5468                                  or err_msg "Must not use",
5469                                  " interface:[..].[all]\n",
5470                                  " with $object->{name} having ip/mask\n",
5471                                  " in $context";
5472
0
0
0
0
                                push @check, @{ $object->{zone}->{interfaces} };
5473                            }
5474                            elsif ($managed) {
5475
0
0
                                push @check,
5476
0
0
                                  grep({ $_->{router}->{managed} ||
5477                                         $_->{router}->{routing_only} }
5478
0
0
                                       @{ $object->{interfaces} });
5479                            }
5480                            else {
5481
0
0
0
0
                                push @check, @{ $object->{interfaces} };
5482                            }
5483                        }
5484                        else {
5485
12
14
                            if ($object->{is_aggregate}) {
5486
0
0
                                err_msg "Must not use",
5487                                  " interface:[any:..].[auto]",
5488                                  " in $context";
5489                            }
5490                            else {
5491
12
15
                                push @objects, get_auto_intf $object, $managed;
5492                            }
5493                        }
5494                    }
5495                    elsif ($type eq 'Interface') {
5496
0
0
                        my $router = $object->{router};
5497
0
0
                        if ($managed && !($router->{managed} ||
5498                                          $router->{routing_only}))
5499                        {
5500
5501                            # Do nothing.
5502                        }
5503                        elsif ($selector eq 'all') {
5504
0
0
                            push @check, get_intf($router);
5505                        }
5506                        else {
5507
0
0
                            push @objects, get_auto_intf $router;
5508                        }
5509                    }
5510                    elsif ($type eq 'Area') {
5511
6
5
                        my @routers;
5512
5513                        # Prevent duplicates and border routers.
5514                        my %seen;
5515
5516                        # Don't add routers at border of this area.
5517
6
6
5
10
                        for my $interface (@{ $object->{border} }) {
5518
4
12
                            $seen{ $interface->{router} } = 1;
5519                        }
5520
5521                        # Add routers at border of security zones inside
5522                        # current area.
5523
6
16
5
20
                        for my $router (
5524
12
14
                            map { $_->{router} }
5525
6
10
                            map { get_intf($_) }
5526                            @{ $object->{zones} }
5527                          )
5528                        {
5529
16
36
                            if (not $seen{$router}) {
5530
6
4
                                push @routers, $router;
5531
6
11
                                $seen{$router} = 1;
5532                            }
5533                        }
5534
6
9
                        if ($managed) {
5535
5536                            # Remove semi managed routers.
5537
4
6
5
15
                            @routers = grep({ $_->{managed} ||
5538                                              $_->{routing_only} }
5539                                            @routers);
5540                        }
5541                        else {
5542
2
3
                            push @routers, map {
5543
2
2
                                my $r = $_->{unmanaged_routers};
5544
2
6
                                $r ? @$r : ()
5545
2
3
                            } @{ $object->{zones} };
5546                        }
5547
6
19
                        if ($selector eq 'all') {
5548
2
10
2
10
                            push @check, map { get_intf($_) } @routers;
5549                        }
5550                        else {
5551
4
6
4
9
                            push @objects, map { get_auto_intf($_) } @routers;
5552                        }
5553                    }
5554                    elsif ($type eq 'Autointerface') {
5555
0
0
                        my $obj = $object->{object};
5556
0
0
                        if (is_router $obj) {
5557
0
0
                            if ($managed && !($obj->{managed} ||
5558                                              $obj->{routing_only}))
5559                            {
5560
5561                                # This router has no managed interfaces.
5562                            }
5563                            elsif ($selector eq 'all') {
5564
0
0
                                push @check, get_intf($obj);
5565                            }
5566                            else {
5567
0
0
                                push @objects, get_auto_intf $obj;
5568                            }
5569                        }
5570                        else {
5571
0
0
                            err_msg "Can't use $object->{name} inside",
5572                              " interface:[..].[$selector] of $context";
5573                        }
5574                    }
5575                    else {
5576
0
0
                        err_msg
5577                          "Unexpected type '$type' in interface:[..] of $context";
5578                    }
5579                }
5580            }
5581
5582            # interface:name.[xxx]
5583            elsif (ref $ext) {
5584
43
45
                my ($selector, $managed) = @$ext;
5585
43
80
                if (my $router = $routers{$name}) {
5586
5587                    # Syntactically impossible.
5588
43
59
                    $managed and internal_err();
5589
43
54
                    if ($selector eq 'all') {
5590
12
24
                        push @check, get_intf($router);
5591                    }
5592                    else {
5593
31
45
                        push @objects, get_auto_intf $router;
5594                    }
5595                }
5596                else {
5597
0
0
                    err_msg("Can't resolve $type:$name.[$selector] in $context");
5598                }
5599            }
5600
5601            # interface:name.name
5602            elsif (my $interface = $interfaces{"$name.$ext"}) {
5603
205
237
                push @objects, $interface;
5604            }
5605            else {
5606
0
0
                err_msg("Can't resolve $type:$name.$ext in $context");
5607            }
5608
5609            # Silently remove unnumbered, bridged and tunnel interfaces
5610            # from automatic groups.
5611
68
112
            push @objects,
5612
64
120
              grep { $_->{ip} ne 'tunnel' }
5613              $clean_autogrp
5614
266
617
              ? grep { $_->{ip} !~ /^(?:unnumbered|bridged)$/ } @check
5615              : @check;
5616        }
5617        elsif (ref $name) {
5618
198
209
            my $sub_objects = [
5619
198
198
333
374
                map { $_->{is_used} = 1; $_; }
5620
183
804
                  grep { not($_->{disabled}) }
5621
183
168
                  @{ expand_group1($name, "$type:[..] of $context") }
5622            ];
5623            my $get_aggregates = sub {
5624
165
178
                my ($object, $ip, $mask) = @_;
5625
165
114
                my @objects;
5626
165
178
                my $type = ref $object;
5627
165
562
                if ($type eq 'Area') {
5628
39
20
51
34
                    push @objects, unique(map({ get_any($_, $ip, $mask) }
5629
20
15
                                              @{ $object->{zones} }));
5630                }
5631                elsif ($type eq 'Network' && $object->{is_aggregate}) {
5632
2
4
                    push @objects, get_any($object->{zone}, $ip, $mask);
5633                }
5634                else {
5635
143
347
                    return;
5636                }
5637
22
55
                return \@objects;
5638
183
626
            };
5639            my $get_networks = sub {
5640
186
185
                my ($object) = @_;
5641
186
133
                my @objects;
5642
186
185
                my $type = ref $object;
5643
186
647
                if ($type eq 'Host' or $type eq 'Interface') {
5644
18
29
                    push @objects, $object->{network};
5645                }
5646                elsif ($type eq 'Network') {
5647
158
206
                    if (!$object->{is_aggregate}) {
5648
143
156
                        push @objects, $object;
5649                    }
5650
5651                    # Take aggregate directly. Don't use next "elsif"
5652                    # clause below, where it would be changed to non
5653                    # matching aggregate with IP 0/0.
5654                    else {
5655
15
15
13
23
                        push @objects, @{ $object->{networks} };
5656                    }
5657                }
5658                elsif (my $aggregates = $get_aggregates->($object, 0, 0)) {
5659
19
31
                    push(@objects,
5660
5661                         # Check type, because $get_aggregates
5662                         # eventually returns non aggregate network if
5663                         # one matches 0/0.
5664
10
21
16
33
                         map({ $_->{is_aggregate} ? @{ $_->{networks} } : $_ }
5665                            @$aggregates));
5666                }
5667                else {
5668
0
0
                    return;
5669                }
5670
186
356
                return \@objects;
5671
183
429
            };
5672
183
434
            if ($type eq 'host') {
5673
12
13
                my $managed = $ext;
5674
12
11
                my @hosts;
5675
12
17
                for my $object (@$sub_objects) {
5676
12
13
                    my $type = ref $object;
5677
12
30
                    if ($type eq 'Host') {
5678
0
0
                        push @hosts, $object;
5679                    }
5680                    elsif ($type eq 'Interface') {
5681
0
0
                        if ($object->{is_managed_host}) {
5682
0
0
                            push @hosts, $object;
5683                        }
5684                        else {
5685
0
0
                            err_msg
5686                              "Unexpected interface in host:[..] of $context";
5687                        }
5688                    }
5689                    elsif (my $networks = $get_networks->($object)) {
5690
12
15
                        for my $network (@$networks) {
5691
12
12
9
21
                            push @hosts, @{ $network->{hosts} };
5692
12
27
                            if (my $managed_hosts = $network->{managed_hosts}) {
5693
8
21
                                push @hosts, @$managed_hosts;
5694                            }
5695                        }
5696                    }
5697                    else {
5698
0
0
                        err_msg
5699                          "Unexpected type '$type' in host:[..] of $context";
5700                    }
5701                }
5702
12
20
                if ($managed) {
5703
4
8
4
12
                    @hosts = grep { $_->{is_managed_host} } @hosts;
5704                }
5705
12
99
                push @objects, @hosts;
5706            }
5707            elsif ($type eq 'network') {
5708
23
40
                $ext and internal_err;
5709
23
20
                my @list;
5710
23
29
                for my $object (@$sub_objects) {
5711
31
39
                    if (my $networks = $get_networks->($object)) {
5712
5713                        # Silently remove from automatic groups:
5714                        # - crosslink network
5715                        # - loopback network of managed device
5716                        # Change loopback network of unmanaged device
5717                        # to loopback interface.
5718                        push @list, $clean_autogrp
5719                          ? map {
5720
47
47
61
76
                            if ($_->{loopback})
5721                            {
5722
2
2
                                my $interfaces = $_->{interfaces};
5723
2
3
                                my $intf = $interfaces->[0];
5724
2
3
                                if ($intf->{router}->{managed}) {
5725
2
4
                                    ();
5726                                }
5727                                else {
5728
0
0
                                    if (@$interfaces > 1) {
5729
0
0
                                        warn_msg(
5730                                            "Must not use $_->{name},",
5731                                            " use interfaces instead"
5732                                            );
5733                                    }
5734
0
0
                                    $intf;
5735                                }
5736                            }
5737                            else {
5738
45
89
                                $_;
5739                            }
5740                          }
5741
31
55
                          grep { not($_->{crosslink}) } @$networks
5742                          : @$networks;
5743                    }
5744                    else {
5745
0
0
                        my $type = ref $object;
5746
0
0
                        err_msg("Unexpected type '$type' in network:[..] of",
5747                            " $context");
5748                    }
5749                }
5750
5751                # Ignore duplicate networks resulting from different
5752                # interfaces connected to the same network.
5753
23
36
                push @objects, unique(@list);
5754            }
5755            elsif ($type eq 'any') {
5756
148
239
                my ($ip, $mask) = $ext ? @$ext : (0, 0);
5757
148
122
                my @list;
5758
148
164
                for my $object (@$sub_objects) {
5759
155
218
                    if (my $aggregates =
5760                        $get_aggregates->($object, $ip, $mask))
5761                    {
5762
12
26
                        push @list, @$aggregates;
5763                    }
5764                    elsif (my $networks = $get_networks->($object)) {
5765
143
143
168
219
                        push @list, map({ get_any($_->{zone}, $ip, $mask) }
5766                                        @$networks);
5767                    }
5768                    else {
5769
0
0
                        my $type = ref $object;
5770
0
0
                        err_msg
5771                          "Unexpected type '$type' in any:[..]",
5772                          " of $context";
5773                    }
5774                }
5775
5776                # Ignore duplicate aggregates resulting from different
5777                # interfaces connected to the same aggregate.
5778
148
207
                push @objects, unique(@list);
5779            }
5780            else {
5781
0
0
                err_msg("Unexpected $type:[..] in $context");
5782            }
5783        }
5784
5785        # An object named simply 'type:name'.
5786        elsif (my $object = $name2object{$type}->{$name}) {
5787
5788
1246
1730
            $ext
5789              and err_msg("Unexpected '.$ext' after $type:$name in $context");
5790
5791            # Split a group into its members.
5792            # There may be two different versions depending of $clean_autogrp.
5793
1246
1541
            if (is_group $object) {
5794
5795                # Two different expanded values, depending on $clean_autogrp.
5796
13
24
                my $ext = $clean_autogrp ? 'clean' : 'noclean';
5797
13
24
                my $attr_name = "expanded_$ext";
5798
5799
13
16
                my $elements = $object->{$attr_name};
5800
5801                # Check for recursive definition.
5802
13
38
                if ($object->{recursive}) {
5803
0
0
                    err_msg("Found recursion in definition of $context");
5804
0
0
                    $object->{$attr_name} = $elements = [];
5805
0
0
                    delete $object->{recursive};
5806                }
5807
5808                # Group has not been converted from names to references.
5809                elsif (not $elements) {
5810
5811                    # Add marker for detection of recursive group definition.
5812
9
13
                    $object->{recursive} = 1;
5813
5814                    # Mark group as used.
5815
9
10
                    $object->{is_used} = 1;
5816
5817
9
140
                    $elements =
5818                      expand_group1($object->{elements}, "$type:$name",
5819                        $clean_autogrp);
5820
9
15
                    delete $object->{recursive};
5821
5822                    # Private group must not reference private element of other
5823                    # context.
5824                    # Public group must not reference private element.
5825
9
38
                    my $private1 = $object->{private} || 'public';
5826
9
11
                    for my $element (@$elements) {
5827
24
49
                        if (my $private2 = $element->{private}) {
5828
0
0
                            $private1 eq $private2
5829                              or err_msg(
5830                                "$private1 $object->{name} must not",
5831                                " reference $private2 $element->{name}"
5832                              );
5833                        }
5834                    }
5835
5836                    # Detect and remove duplicate values in group.
5837
9
9
                    my %unique;
5838                    my @duplicate;
5839
9
15
                    for my $obj (@$elements) {
5840
24
64
                        if ($unique{$obj}++) {
5841
0
0
                            push @duplicate, $obj;
5842
0
0
                            $obj = undef;
5843                        }
5844                    }
5845
9
19
                    if (@duplicate) {
5846
0
0
0
0
                        $elements = [ grep { defined $_ } @$elements ];
5847
0
0
                        my $msg = "Duplicate elements in $type:$name:\n "
5848
0
0
                          . join("\n ", map { $_->{name} } @duplicate);
5849
0
0
                        warn_msg($msg);
5850                    }
5851
5852                    # Cache result for further references to the same group
5853                    # in same $clean_autogrp context.
5854
9
19
                    $object->{$attr_name} = $elements;
5855                }
5856
13
34
                push @objects, @$elements;
5857            }
5858
5859            # Substitute aggregate by aggregate set of zone cluster.
5860            elsif ($object->{is_aggregate} && $object->{zone}->{zone_cluster}) {
5861
0
0
0
0
                my ($ip, $mask) = @{$object}{qw(ip mask)};
5862
0
0
                push(@objects,
5863                    get_cluster_aggregates($object->{zone}, $ip, $mask));
5864            }
5865
5866            else {
5867
1233
2446
                push @objects, $object;
5868            }
5869
5870        }
5871        else {
5872
0
0
            err_msg("Can't resolve $type:$name in $context");
5873        }
5874    }
5875
1763
2561
    return \@objects;
5876}
5877
5878# Remove and warn about duplicate values in group.
5879sub remove_duplicates {
5880
1530
0
1381
    my ($aref, $context) = @_;
5881
1530
1133
    my %seen;
5882    my @duplicate;
5883
1530
1552
    for my $obj (@$aref) {
5884
2022
5553
        if ($seen{$obj}++) {
5885
1
2
            push @duplicate, $obj;
5886
1
1
            $obj = undef;
5887        }
5888    }
5889
1530
2373
    if (@duplicate) {
5890
1
4
        my $msg = "Duplicate elements in $context:\n "
5891
1
3
          . join("\n ", map { $_->{name} } @duplicate);
5892
1
2
        warn_msg($msg);
5893
1
3
2
5
        $aref = [ grep { defined $_ } @$aref ];
5894    }
5895
1530
2175
    return $aref;
5896}
5897
5898sub expand_group {
5899
1525
0
1443
    my ($obref, $context) = @_;
5900
1525
1817
    my $aref = expand_group1 $obref, $context, 'clean_autogrp';
5901
1525
1913
    $aref = remove_duplicates($aref, $context);
5902
5903    # Ignore disabled objects.
5904
1525
1189
    my $changed;
5905
1525
1494
    for my $object (@$aref) {
5906
2011
3786
        if ($object->{disabled}) {
5907
2
2
            $object = undef;
5908
2
2
            $changed = 1;
5909        }
5910    }
5911
1525
2
2105
4
    $aref = [ grep { defined $_ } @$aref ] if $changed;
5912
1525
2263
    return $aref;
5913}
5914
5915my %subnet_warning_seen;
5916
5917sub expand_group_in_rule {
5918
602
0
947
    my ($obref, $context, $convert_hosts) = @_;
5919
602
734
    my $aref = expand_group($obref, $context);
5920
5921    # Ignore unusable objects.
5922
602
477
    my $changed;
5923
602
601
    for my $object (@$aref) {
5924
766
551
        my $ignore;
5925
766
910
        if (is_network $object) {
5926
565
1870
            if ($object->{ip} eq 'unnumbered') {
5927
0
0
                $ignore = "unnumbered $object->{name}";
5928            }
5929            elsif ($object->{crosslink}) {
5930
0
0
                $ignore = "crosslink $object->{name}";
5931            }
5932            elsif ($object->{is_aggregate}) {
5933
94
218
                if ($object->{is_tunnel}) {
5934
0
0
                    $ignore = "$object->{name} with tunnel";
5935                }
5936                elsif ($object->{has_id_hosts}) {
5937
1
2
                    $ignore = "$object->{name} with software clients"
5938                }                    
5939            }
5940        }
5941        elsif (is_interface $object) {
5942
83
227
            if ($object->{ip} =~ /^(short|unnumbered)$/) {
5943
0
0
                $ignore = "$object->{ip} $object->{name}";
5944            }
5945        }
5946        elsif (is_area $object) {
5947
0
0
            $ignore = $object->{name};
5948        }
5949
766
1520
        if ($ignore) {
5950
1
6
            $object = undef;
5951
1
1
            $changed = 1;
5952
1
4
            warn_msg("Ignoring $ignore in $context");
5953        }
5954    }
5955
602
1
837
2
    $aref = [ grep { defined $_ } @$aref ] if $changed;
5956
5957
602
749
    if ($convert_hosts) {
5958
596
483
        my @subnets;
5959        my %subnet2host;
5960
0
0
        my @other;
5961
596
602
        for my $obj (@$aref) {
5962
5963#           debug("group:$obj->{name}");
5964
752
851
            if (is_host $obj) {
5965
97
97
87
137
                for my $subnet (@{ $obj->{subnets} }) {
5966
5967                    # Handle special case, where network and subnet
5968                    # have identical address.
5969                    # E.g. range = 10.1.1.0-10.1.1.255.
5970                    # Convert subnet to network, because
5971                    # - different objects with identical IP
5972                    #   can't be checked and optimized properly,
5973                    # - find_chains would fail, when building binary tree.
5974
103
283
                    if ($subnet->{mask} == $subnet->{network}->{mask}) {
5975
1
2
                        my $network = $subnet->{network};
5976
1
5
                        if (not $network->{has_id_hosts} and
5977                            not $subnet_warning_seen{$subnet}++)
5978                        {
5979
1
9
                            warn_msg("Use $network->{name} instead of",
5980                                     " $subnet->{name}\n",
5981                                     " because both have identical address");
5982                        }
5983
1
4
                        push @other, $network;
5984                    }
5985                    elsif (my $host = $subnet2host{$subnet}) {
5986
0
0
                        warn_msg("$obj->{name} and $host->{name}",
5987                                 " overlap in $context");
5988                    }
5989                    else {
5990
102
149
                        $subnet2host{$subnet} = $obj;
5991
102
231
                        push @subnets, $subnet;
5992                    }
5993                }
5994            }
5995            else {
5996
655
989
                push @other, $obj;
5997            }
5998        }
5999
596
801
        push @other, ($convert_hosts eq 'no_combine')
6000          ? @subnets
6001
596
858
          : @{ combine_subnets \@subnets };
6002
596
1207
        return \@other;
6003    }
6004    else {
6005
6
12
        return $aref;
6006    }
6007
6008}
6009
6010sub check_unused_groups {
6011    my $check = sub {
6012
452
432
        my ($hash, $print_type) = @_;
6013
452
1027
        my $print = $print_type eq 'warn' ? \&warn_msg : \&err_msg;
6014
452
1159
        for my $name (sort keys %$hash) {
6015
2
3
            my $value = $hash->{$name};
6016
2
8
            next if $value->{is_used};
6017
0
0
            $print->("unused $value->{name}");
6018        }
6019
226
0
750
    };
6020
226
478
    if (my $conf = $config{check_unused_groups}) {
6021
226
307
        for my $hash (\%groups, \%protocolgroups) {
6022
452
890
            $check->($hash, $conf);
6023        }
6024    }
6025
226
453
    if (my $conf = $config{check_unused_protocols}) {
6026
0
0
        for my $hash (\%protocols) {
6027
0
0
            $check->($hash, $conf);
6028        }
6029    }
6030
6031    # Not used any longer; free memory.
6032
226
275
    %groups = ();
6033
226
1166
    return;
6034}
6035
6036# Result:
6037# Reference to array with elements
6038# - non TCP/UDP protocol
6039# - dst_range of (splitted) TCP/UDP protocol
6040# - [ src_range, dst_range, orig_prt ]
6041#     of (splitted) protocol having src_range or main_prt.
6042sub expand_protocols {
6043
333
0
331
    my ($aref, $context) = @_;
6044
333
260
    my @protocols;
6045
333
379
    for my $pair (@$aref) {
6046
6047        # Handle anonymous protocol.
6048
354
650
        if (ref($pair) eq 'HASH') {
6049
322
344
            push @protocols, $pair;
6050
322
462
            next;
6051        }
6052
6053
32
41
        my ($type, $name) = @$pair;
6054
32
64
        if ($type eq 'protocol') {
6055
31
61
            if (my $prt = $protocols{$name}) {
6056
31
31
                push @protocols, $prt;
6057
6058                # Currently needed by external program 'cut-netspoc'.
6059
31
68
                $prt->{is_used} = 1;
6060            }
6061            else {
6062
0
0
                err_msg("Can't resolve reference to $type:$name in $context");
6063
0
0
                next;
6064            }
6065        }
6066        elsif ($type eq 'protocolgroup') {
6067
1
3
            if (my $prtgroup = $protocolgroups{$name}) {
6068
1
1
                my $elements = $prtgroup->{elements};
6069
1
4
                if ($elements eq 'recursive') {
6070
0
0
                    err_msg("Found recursion in definition of $context");
6071
0
0
                    $prtgroup->{elements} = $elements = [];
6072                }
6073
6074                # Check if it has already been converted
6075                # from names to references.
6076                elsif (not $prtgroup->{is_used}) {
6077
6078                    # Detect recursive definitions.
6079
1
2
                    $prtgroup->{elements} = 'recursive';
6080
1
1
                    $prtgroup->{is_used}  = 1;
6081
1
7
                    $elements = expand_protocols($elements, "$type:$name");
6082
6083                    # Cache result for further references to the same group.
6084
1
2
                    $prtgroup->{elements} = $elements;
6085                }
6086
6087                # Split only once.
6088
1
2
                push @protocols, @$elements;
6089            }
6090            else {
6091
0
0
                err_msg("Can't resolve reference to $type:$name in $context");
6092
0
0
                next;
6093            }
6094        }
6095        else {
6096
0
0
            err_msg("Unknown type of $type:$name in $context");
6097        }
6098    }
6099
333
690
    return \@protocols;
6100}
6101
6102# Expand splitted protocols.
6103sub split_protocols {
6104
319
0
300
    my ($protocols, $context) = @_;
6105
319
252
    my @splitted_protocols;
6106
319
359
    for my $prt (@$protocols) {
6107
340
348
        my $proto = $prt->{proto};
6108
340
820
        if (not($proto eq 'tcp' or $proto eq 'udp')) {
6109
76
81
            push @splitted_protocols, $prt;
6110
76
120
            next;
6111        }
6112
6113        # Collect splitted src_range / dst_range pairs.
6114
264
251
        my $dst_range = $prt->{dst_range};
6115
264
240
        my $src_range = $prt->{src_range};
6116
6117        # Remember original protocol as third value
6118        # - if src_range is given or
6119        # - if original protocol has flags or
6120        # - if $dst_range is shared between different protocols.
6121        # Cache list of triples at original protocol for re-use.
6122
264
1679
        if ($src_range or $prt->{flags} or $dst_range->{name} ne $prt->{name}) {
6123
28
34
            my $aref_list = $prt->{src_dst_range_list};
6124
28
45
            if (not $aref_list) {
6125
26
41
                for my $src_split (expand_splitted_protocol $src_range) {
6126
26
36
                    for my $dst_split (expand_splitted_protocol $dst_range) {
6127
26
78
                        push @$aref_list, [$src_split, $dst_split, $prt];
6128                    }
6129                }
6130
26
38
                $prt->{src_dst_range_list} = $aref_list;
6131            }
6132
28
50
            push @splitted_protocols, @$aref_list;
6133        }
6134        else {
6135
236
316
            for my $dst_split (expand_splitted_protocol $dst_range) {
6136
237
596
                push @splitted_protocols, $dst_split;
6137            }
6138        }
6139    }
6140
319
458
    return \@splitted_protocols;
6141}
6142
6143sub path_auto_interfaces;
6144
6145# Hash with attributes deny, supernet, permit for storing
6146# expanded rules of different type.
6147our %expanded_rules;
6148
6149# Hash for ordering all rules.
6150# Put attributes with small value set first, to get a more
6151# memory efficient tree with few branches at root.
6152# $rule_tree{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}->{$prt}
6153#  = $rule;
6154my %rule_tree;
6155
6156# Collect deleted rules for further inspection.
6157my @deleted_rules;
6158
6159# Add rules to %rule_tree for efficient look up.
6160sub add_rules {
6161
1020
0
889
    my ($rules_ref, $rule_tree) = @_;
6162
1020
1888
    $rule_tree ||= \%rule_tree;
6163
6164
1020
1095
    for my $rule (@$rules_ref) {
6165
630
1055
        my ($stateless, $deny, $src, $dst, $src_range, $prt) =
6166
630
889
          @{$rule}{ qw(stateless deny src dst src_range prt) };
6167
6168        # A rule with an interface as destination may be marked as deleted
6169        # during global optimization. But in some cases, code for this rule
6170        # must be generated anyway. This happens, if
6171        # - it is an interface of a managed router and
6172        # - code is generated for exactly this router.
6173        # Mark such rules for easier handling.
6174
630
756
        if (is_interface($dst) && ($dst->{router}->{managed} ||
6175                                   $dst->{router}->{routing_only}))
6176        {
6177
125
144
            $rule->{managed_intf} = 1;
6178        }
6179
630
1450
        $stateless ||= '';
6180
630
1362
        $deny      ||= '';
6181
630
1287
        $src_range ||= $prt_ip;
6182
630
2030
        my $old_rule =
6183          $rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}
6184          ->{$prt};
6185
630
854
        if ($old_rule) {
6186
6187            # Found identical rule.
6188
7
6
            $rule->{deleted} = $old_rule;
6189
7
6
            push @deleted_rules, $rule;
6190
7
12
            next;
6191        }
6192
6193#       debug("Add:", print_rule $rule);
6194
623
2148
        $rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}
6195          ->{$prt} = $rule;
6196    }
6197
1020
1046
    return;
6198}
6199
6200my %obj2zone;
6201
6202sub get_zone {
6203
780
0
673
    my ($obj) = @_;
6204
780
767
    my $type = ref $obj;
6205
780
564
    my $result;
6206
6207    # A router or network with [auto] interface.
6208
780
1132
    if ($type eq 'Autointerface') {
6209
21
20
        $obj  = $obj->{object};
6210
21
22
        $type = ref $obj;
6211    }
6212
6213
780
1138
    if ($type eq 'Network') {
6214
589
580
        $result = $obj->{zone};
6215    }
6216    elsif ($type eq 'Subnet') {
6217
93
121
        $result = $obj->{network}->{zone};
6218    }
6219    elsif ($type eq 'Interface') {
6220
82
142
        if ($obj->{router}->{managed}) {
6221
57
59
            $result = $obj->{router};
6222        }
6223        else {
6224
25
29
            $result = $obj->{network}->{zone};
6225        }
6226    }
6227
6228    # Only used when called from expand_rules.
6229    elsif ($type eq 'Router') {
6230
16
22
        if ($obj->{managed}) {
6231
7
7
            $result = $obj;
6232        }
6233        else {
6234
9
15
            $result = $obj->{interfaces}->[0]->{network}->{zone};
6235        }
6236    }
6237    elsif ($type eq 'Host') {
6238
0
0
        $result = $obj->{network}->{zone};
6239    }
6240    else {
6241
0
0
        internal_err("unexpected $obj->{name}");
6242    }
6243
780
2066
    return($obj2zone{$obj} = $result);
6244}
6245
6246sub path_walk;
6247
6248sub expand_special  {
6249
958
0
1318
    my ($src, $dst, $flags, $context) = @_;
6250
958
690
    my @result;
6251
958
1070
    if (is_autointerface $src) {
6252
21
28
        for my $interface (path_auto_interfaces $src, $dst) {
6253
34
64
            if ($interface->{ip} eq 'short') {
6254
0
0
                err_msg "'$interface->{ip}' $interface->{name}",
6255                  " (from .[auto])\n", " must not be used in rule of $context";
6256            }
6257            elsif ($interface->{ip} eq 'unnumbered') {
6258
6259                # Ignore unnumbered interfaces.
6260            }
6261            else {
6262
34
45
                push @result, $interface;
6263            }
6264        }
6265    }
6266    else {
6267
937
986
        @result = ($src);
6268    }
6269
958
1620
    if ($flags->{net}) {
6270
4
5
        my @networks;
6271        my @other;
6272
4
6
        for my $obj (@result) {
6273
4
4
            my $type = ref $obj;
6274
4
3
            my $network;
6275
4
17
            if ($type eq 'Network') {
6276
0
0
                $network = $obj;
6277            }
6278            elsif ($type eq 'Subnet' or $type eq 'Host') {
6279
3
5
                if ($obj->{id}) {
6280
0
0
                    push @other, $obj;
6281
0
0
                    next;
6282                }
6283                else {
6284
3
4
                    $network = $obj->{network};
6285                }
6286            }
6287            elsif ($type eq 'Interface') {
6288
1
3
                if ($obj->{router}->{managed} || $obj->{loopback}) {
6289
1
2
                    push @other, $obj;
6290
1
2
                    next;
6291                }
6292                else {
6293
0
0
                    $network = $obj->{network};
6294                }
6295            }
6296            else {
6297
0
0
                internal_err("unexpected $obj->{name}");
6298            }
6299
3
10
            push @networks, $network if $network->{ip} ne 'unnumbered';
6300        }
6301
4
7
        @result = (@other, unique(@networks));
6302#        debug "special: ", join(', ', map { $_->{name} } @result);
6303    }
6304
958
1306
    if ($flags->{any}) {
6305
0
0
        my %zones;
6306
0
0
        for my $obj (@result) {
6307
0
0
            my $type = ref $obj;
6308
0
0
            my $zone;
6309
0
0
            if ($type eq 'Network') {
6310
0
0
                $zone = $obj->{zone};
6311            }
6312            elsif ($type eq 'Subnet' or $type eq 'Interface' or $type eq 'Host')
6313            {
6314
0
0
                $zone = $obj->{network}->{zone};
6315            }
6316            else {
6317
0
0
                internal_err("unexpected $obj->{name}");
6318            }
6319
0
0
            $zones{$zone} = $zone;
6320        }
6321
0
0
0
0
        @result = map { get_any($_, 0, 0) } values %zones;
6322    }
6323
958
1853
    return @result;
6324}
6325
6326# Add managed hosts of networks and aggregates.
6327sub add_managed_hosts {
6328
298
0
310
    my ($aref, $context) = @_;
6329
298
239
    my @extra;
6330
298
336
    for my $object (@$aref) {
6331
368
878
        my $managed_hosts = $object->{managed_hosts} or next;
6332
5
8
        push @extra, @$managed_hosts;
6333    }
6334
298
524
    if (@extra) {
6335
5
5
        push @$aref, @extra;
6336
5
7
        $aref = remove_duplicates($aref, $context);
6337    }
6338
298
343
    return $aref;
6339}
6340
6341# This handles a rule between objects inside a single security zone or
6342# between interfaces of a single managed router.
6343# Show warning or error message if rule is between
6344# - different interfaces or
6345# - different networks or
6346# - subnets/hosts of different networks.
6347# Rules between identical objects are silently ignored.
6348# But a message is shown if a service only has rules between identical objects.
6349sub collect_unenforceable  {
6350
23
0
23
    my ($src, $dst, $zone, $service) = @_;
6351
6352
23
43
    if ($zone->{has_unenforceable}) {
6353
2
3
        $zone->{seen_unenforceable} = 1;
6354
2
7
        $service->{silent_unenforceable} = 1;
6355
2
2
        return;
6356    }
6357
6358
21
21
    my $context = $service->{name};
6359
21
24
    $service->{silent_unenforceable} = 1;
6360
6361    # A rule between identical objects is a common case
6362    # which results from rules with "src=user;dst=user;".
6363
21
47
    return if $src eq $dst;
6364
6365
8
11
    if (is_router $zone) {
6366
6367        # Auto interface is assumed to be identical
6368        # to each other interface of a single router.
6369
0
0
        return if is_autointerface($src) or is_autointerface($dst);
6370    }
6371    elsif (is_subnet $src and is_subnet($dst)) {
6372
6373        # For rules with different subnets of a single network we don't
6374        # know if the subnets have been split from a single range.
6375        # E.g. range 1-4 becomes four subnets 1,2-3,4
6376        # For most splits the resulting subnets would be adjacent.
6377        # Hence we check for adjacency.
6378
2
6
        if ($src->{network} eq $dst->{network}) {
6379
2
4
            my ($a, $b) = $src->{ip} > $dst->{ip} ? ($dst, $src) : ($src, $dst);
6380
2
3
            if ($a->{ip} + complement_32bit($a->{mask}) + 1 == $b->{ip}) {
6381
0
0
                return;
6382            }
6383        }
6384    }
6385    elsif ($src->{is_aggregate} && $dst->{is_aggregate}) {
6386
6387        # Both are aggregates,
6388        # - belonging to same zone cluster and
6389        # - having identical ip and mask
6390
0
0
        return if (zone_eq($src->{zone}, $dst->{zone})
6391                   && $src->{ip} == $dst->{ip}
6392                   && $src->{mask} == $dst->{mask});
6393    }
6394    elsif ($src->{is_aggregate} && $src->{mask} == 0) {
6395
6396        # This is a common case, which results from rules like
6397        # group:some_networks -> any:[group:some_networks]
6398
0
0
        return if zone_eq($src->{zone}, get_zone($dst))
6399    }
6400    elsif ($dst->{is_aggregate} && $dst->{mask} == 0 ) {
6401
3
5
        return if zone_eq($dst->{zone}, get_zone($src))
6402    }
6403    elsif ($dst->{managed_hosts}) {
6404
6405        # Network or aggregate was only used for its managed_hosts
6406        # to be added automatically in expand_group.
6407
0
0
        return;
6408    }
6409
5
28
    $service->{seen_unenforceable}->{$src}->{$dst} ||= [ $src, $dst ];
6410
5
8
    return;
6411}
6412
6413sub show_unenforceable {
6414
261
0
265
    my ($service) = @_;
6415
261
284
    my $context = $service->{name};
6416
6417
261
525
    if ($service->{has_unenforceable} &&
6418        (! $service->{seen_unenforceable} || ! $service->{seen_enforceable}))
6419    {
6420
1
4
        warn_msg("Useless attribute 'has_unenforceable' at $context");
6421    }
6422
261
479
    return if ! $config{check_unenforceable};
6423
261
399
    return if $service->{disabled};
6424
6425
261
493
    my $print = $config{check_unenforceable} eq 'warn' ? \&warn_msg : \&err_msg;
6426
6427    # Warning about fully unenforceable service can't be disabled with
6428    # attribute has_unenforceable.
6429
261
559
    if (! delete $service->{seen_enforceable}) {
6430
6431        # Don't warn on empty service without any expanded rules.
6432
5
24
        if ($service->{seen_unenforceable} || $service->{silent_unenforceable})
6433        {
6434
3
10
            $print->("$context is fully unenforceable");
6435        }
6436
5
8
        return;
6437    }
6438
256
407
    return if $service->{has_unenforceable};
6439
6440
255
450
    if (my $hash = delete $service->{seen_unenforceable}) {
6441
1
2
        my $msg = "$context has unenforceable rules:";
6442
1
2
        for my $hash (values %$hash) {
6443
1
2
            for my $aref (values %$hash) {
6444
1
1
                my ($src, $dst) = @$aref;
6445
1
5
                $msg .= "\n src=$src->{name}; dst=$dst->{name}";
6446            }
6447        }
6448
1
2
        $print->($msg);
6449    }
6450
255
250
    delete $service->{silent_unenforceable};
6451
255
322
    return;
6452}
6453
6454sub warn_useless_unenforceable {
6455
315
0
364
    for my $zone (@zones) {
6456
825
1408
        $zone->{has_unenforceable} or next;
6457
2
5
        $zone->{seen_unenforceable} and next;
6458
1
2
        my $agg00 = $zone->{ipmask2aggregate}->{'0/0'};
6459
1
2
        my $name = $agg00 ? $agg00->{name} : $zone->{name};
6460
1
3
        warn_msg("Useless attribute 'has_unenforceable' at $name");
6461    }
6462
315
297
    return;
6463}
6464
6465sub show_deleted_rules1 {
6466
315
0
522
    return if not @deleted_rules;
6467
1
2
    my %sname2oname2deleted;
6468  RULE:
6469
1
1
    for my $rule (@deleted_rules) {
6470
1
4
        my $other = $rule->{deleted};
6471
6472
1
4
        my $prt1 = $rule->{orig_prt}  || $rule->{prt};
6473
1
4
        my $prt2 = $other->{orig_prt} || $other->{prt};
6474
1
3
        next if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps};
6475
6476
1
2
        my $service  = $rule->{rule}->{service};
6477
1
1
        my $oservice = $other->{rule}->{service};
6478
1
2
        if (my $overlaps = $service->{overlaps}) {
6479
1
2
            for my $overlap (@$overlaps) {
6480
1
2
                if ($oservice eq $overlap) {
6481
1
3
                    $service->{overlaps_used}->{$overlap} = $overlap;
6482
1
3
                    next RULE;
6483                }
6484            }
6485        }
6486
0
0
        if (my $overlaps = $oservice->{overlaps}) {
6487
0
0
            for my $overlap (@$overlaps) {
6488
0
0
                if ($service eq $overlap) {
6489
0
0
                    $oservice->{overlaps_used}->{$overlap} = $overlap;
6490
0
0
                    next RULE;
6491                }
6492            }
6493        }
6494
0
0
        my $sname = $service->{name};
6495
0
0
        my $oname = $oservice->{name};
6496
0
0
        my $pfile = $service->{file};
6497
0
0
        my $ofile = $oservice->{file};
6498
0
0
        $pfile =~ s/.*?([^\/]+)$/$1/;
6499
0
0
        $ofile =~ s/.*?([^\/]+)$/$1/;
6500
0
0
0
0
        push(@{ $sname2oname2deleted{$sname}->{$oname} }, $rule);
6501    }
6502
1
3
    if (my $action = $config{check_duplicate_rules}) {
6503
1
2
        my $print = $action eq 'warn' ? \&warn_msg : \&err_msg;
6504
1
3
        for my $sname (sort keys %sname2oname2deleted) {
6505
0
0
            my $hash = $sname2oname2deleted{$sname};
6506
0
0
            for my $oname (sort keys %$hash) {
6507
0
0
                my $aref = $hash->{$oname};
6508
0
0
                my $msg  = "Duplicate rules in $sname and $oname:\n  ";
6509
0
0
0
0
                $msg .= join("\n  ", map { print_rule $_ } @$aref);
6510
0
0
                $print->($msg);
6511            }
6512        }
6513    }
6514
6515    # Variable will be reused during sub optimize.
6516
1
2
    @deleted_rules = ();
6517
1
1
    return;
6518}
6519
6520sub collect_redundant_rules {
6521
32
0
32
    my ($rule, $other) = @_;
6522
6523    # Ignore automatically generated rules from crypto or from reverse rules.
6524
32
60
    return if !$rule->{rule};
6525
24
37
    return if !$other->{rule};
6526
6527
24
64
    my $prt1 = $rule->{orig_prt}  || $rule->{prt};
6528
24
60
    my $prt2 = $other->{orig_prt} || $other->{prt};
6529
24
61
    return if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps};
6530
6531    # Rule is still needed at device of $rule->{dst}.
6532
24
48
    if ($rule->{managed_intf} and not $rule->{deleted}->{managed_intf}) {
6533
1
1
        return;
6534    }
6535
6536    # Automatically generated reverse rule for stateless router
6537    # is still needed, even for stateful routers for static routes.
6538
23
25
    my $src = $rule->{src};
6539
23
29
    if (is_interface($src)) {
6540
0
0
        my $router = $src->{router};
6541
0
0
        if ($router->{managed} || $router->{routing_only}) {
6542
0
0
            return;
6543        }
6544    }
6545
6546
23
30
    my $service  = $rule->{rule}->{service};
6547
23
22
    my $oservice = $other->{rule}->{service};
6548
23
41
    if (!$oservice) {
6549
0
0
        debug "d:", print_rule $rule;
6550
0
0
        debug "o:", print_rule $other;
6551    }
6552
23
43
    if (my $overlaps = $service->{overlaps}) {
6553
4
4
        for my $overlap (@$overlaps) {
6554
4
10
            if ($oservice eq $overlap) {
6555
3
7
                $service->{overlaps_used}->{$overlap} = $overlap;
6556
3
4
                return;
6557            }
6558        }
6559    }
6560
20
27
    push @deleted_rules, [ $rule, $other ];
6561
20
25
    return;
6562}
6563
6564sub show_deleted_rules2 {
6565
226
0
361
    return if not @deleted_rules;
6566
13
14
    my %sname2oname2deleted;
6567
13
15
    for my $pair (@deleted_rules) {
6568
20
24
        my ($rule, $other) = @$pair;
6569
6570
20
22
        my $service  = $rule->{rule}->{service};
6571
20
22
        my $oservice = $other->{rule}->{service};
6572
20
23
        my $sname = $service->{name};
6573
20
18
        my $oname = $oservice->{name};
6574
20
20
        my $pfile = $service->{file};
6575
20
19
        my $ofile = $oservice->{file};
6576
20
199
        $pfile =~ s/.*?([^\/]+)$/$1/;
6577
20
166
        $ofile =~ s/.*?([^\/]+)$/$1/;
6578
20
20
22
80
        push(@{ $sname2oname2deleted{$sname}->{$oname} }, [ $rule, $other ]);
6579    }
6580
13
32
    if (my $action = $config{check_redundant_rules}) {
6581
11
21
        my $print = $action eq 'warn' ? \&warn_msg : \&err_msg;
6582
11
28
        for my $sname (sort keys %sname2oname2deleted) {
6583
15
19
            my $hash = $sname2oname2deleted{$sname};
6584
15
36
            for my $oname (sort keys %$hash) {
6585
17
22
                my $aref = $hash->{$oname};
6586
17
43
                my $msg  = "Redundant rules in $sname compared to $oname:\n  ";
6587
18
19
                $msg .= join(
6588                    "\n  ",
6589                    map {
6590
17
25
                        my ($r, $o) = @$_;
6591
18
28
                        print_rule($r) . "\n< " . print_rule($o);
6592                    } @$aref
6593                    );
6594
17
26
                $print->($msg);
6595            }
6596        }
6597    }
6598
6599    # Free memory.
6600
13
23
    @deleted_rules = ();
6601
6602
13
31
    return;
6603}
6604
6605sub warn_unused_overlaps {
6606
226
0
465
    for my $key (sort keys %services) {
6607
239
309
        my $service = $services{$key};
6608
239
386
        next if $service->{disabled};
6609
239
538
        if (my $overlaps = $service->{overlaps}) {
6610
4
5
            my $used = delete $service->{overlaps_used};
6611
4
7
            for my $overlap (@$overlaps) {
6612
4
7
                next if $overlap->{disabled};
6613
4
19
                $used->{$overlap}
6614                  or warn_msg("Useless 'overlaps = $overlap->{name}'",
6615                              " in $service->{name}");
6616            }
6617        }
6618    }
6619
226
232
    return;
6620}
6621
6622# All log tags defined at some routers.
6623my %known_log;
6624
6625sub collect_log {
6626
315
0
363
    for my $router (@managed_routers) {
6627
451
928
        my $log = $router->{log} or next;
6628
19
30
        for my $tag (keys %$log) {
6629
34
61
            $known_log{$tag} = 1;
6630        }
6631    }
6632
315
285
    return;
6633}
6634
6635sub check_log {
6636
18
0
16
    my ($log, $context) = @_;
6637
18
16
    for my $tag (@$log) {
6638
20
44
        $known_log{$tag} and next;
6639
1
4
        warn_msg("Referencing unknown '$tag' in log of $context");
6640
1
2
        aref_delete($log, $tag);
6641    }
6642
18
20
    return;
6643}
6644
6645# Normalize lists of log tags at different rules in such a way,
6646# that equal sets of tags are represented by 'eq' array references.
6647my %key2log;
6648sub normalize_log {
6649
17
0
14
    my ($log) = @_;
6650
17
29
    my @tags = sort @$log;
6651
17
25
    my $key = join(',', @tags);
6652
17
62
    return $key2log{$key} ||= \@tags;
6653}        
6654
6655# Parameters:
6656# - The service.
6657# - Reference to array for storing resulting expanded rules.
6658# - Flag which will be passed on to expand_group.
6659sub expand_rules {
6660
261
0
276
    my ($service, $result, $convert_hosts) = @_;
6661
261
269
    my $rules_ref = $service->{rules};
6662
261
255
    my $user      = $service->{user};
6663
261
232
    my $context   = $service->{name};
6664
261
237
    my $disabled  = $service->{disabled};
6665
261
235
    my $private   = $service->{private};
6666
261
591
    my $foreach   = $service->{foreach};
6667
6668
261
291
    for my $unexpanded (@$rules_ref) {
6669
298
381
        my $deny = $unexpanded->{action} eq 'deny';
6670
298
271
        my $log  = $unexpanded->{log};
6671
298
444
        if ($log) {
6672
18
21
            check_log($log, $context);
6673
18
34
            if (@$log) {
6674
17
21
                $log = normalize_log($log);
6675            }
6676            else {
6677
1
1
                $log = undef;
6678            }
6679        }
6680
298
658
        my $prt_list = split_protocols(expand_protocols($unexpanded->{prt},
6681                                                        "rule in $context"));
6682
298
556
        for my $element ($foreach ? @$user : $user) {
6683
298
318
            $user_object->{elements} = $element;
6684
298
704
            my $src = expand_group_in_rule($unexpanded->{src},
6685                                           "src of rule in $context",
6686                                           $convert_hosts);
6687
298
461
            my $dst_context =  "dst of rule in $context";
6688
298
778
            my $dst = expand_group_in_rule($unexpanded->{dst},
6689                                           $dst_context,
6690                                           $convert_hosts);
6691
298
463
            $dst = add_managed_hosts($dst, $dst_context);
6692
298
323
            for my $prt (@$prt_list) {
6693
6694                # Prevent modification of original array.
6695
313
275
                my $prt = $prt;
6696
6697                # If $prt is duplicate of an identical protocol,
6698                # use the main protocol, but remember the original
6699                # one for debugging / comments.
6700
313
595
                my $orig_prt;
6701                my $src_range;
6702
313
802
                if (ref $prt eq 'ARRAY') {
6703
23
39
                    ($src_range, $prt, $orig_prt) = @$prt;
6704                }
6705                elsif (my $main_prt = $prt->{main}) {
6706
34
27
                    $orig_prt = $prt;
6707
34
35
                    $prt      = $main_prt;
6708                }
6709
6710
313
468
                my $flags     = $orig_prt ? $orig_prt->{flags} : $prt->{flags};
6711
313
313
                my $stateless = $flags->{stateless};
6712
313
487
                my ($src, $dst) =
6713                  $flags->{reversed} ? ($dst, $src) : ($src, $dst);
6714
6715
313
347
                for my $src (@$src) {
6716
409
1062
                    my $src_zone = $obj2zone{$src} || get_zone $src;
6717
409
406
                    my $src_zone_cluster = $src_zone->{zone_cluster};
6718
409
452
                    for my $dst (@$dst) {
6719
502
1102
                        my $dst_zone = $obj2zone{$dst} || get_zone $dst;
6720
502
477
                        my $dst_zone_cluster = $dst_zone->{zone_cluster};
6721
502
1600
                        if (   $src_zone eq $dst_zone
6722                            || $src_zone_cluster
6723                            && $dst_zone_cluster
6724                            && $src_zone_cluster eq $dst_zone_cluster)
6725                        {
6726
23
36
                            collect_unenforceable(
6727                                $src, $dst, $src_zone, $service);
6728
23
65
                            next;
6729                        }
6730
6731                        # At least one rule is enforceable.
6732                        # This is used to decide, if a service is fully
6733                        # unenforceable.
6734
479
531
                        $service->{seen_enforceable} = 1;
6735
6736
479
1044
                        my @src =
6737                            expand_special($src, $dst, $flags->{src}, $context)
6738                            or next;    # Prevent multiple error messages.
6739
479
2325
                        my @dst =
6740                            expand_special($dst, $src, $flags->{dst}, $context);
6741
479
634
                        for my $src (@src) {
6742
479
456
                            for my $dst (@dst) {
6743
492
579
                                if ($private) {
6744
0
0
                                    my $src_p = $src->{private};
6745
0
0
                                    my $dst_p = $dst->{private};
6746
0
0
                                    $src_p and $src_p eq $private
6747                                      or $dst_p and $dst_p eq $private
6748                                      or err_msg
6749                                      "Rule of $private.private $context",
6750                                      " must reference at least one object",
6751                                      " out of $private.private";
6752                                }
6753                                else {
6754
492
751
                                    $src->{private}
6755                                      and err_msg
6756                                      "Rule of public $context must not",
6757                                      " reference $src->{name} of",
6758                                      " $src->{private}.private";
6759
492
750
                                    $dst->{private}
6760                                      and err_msg
6761                                      "Rule of public $context must not",
6762                                      " reference $dst->{name} of",
6763                                      " $dst->{private}.private";
6764                                }
6765
492
646
                                next if $disabled;
6766
6767
492
1041
                                my $rule = {
6768                                    src  => $src,
6769                                    dst  => $dst,
6770                                    prt  => $prt,
6771                                    rule => $unexpanded
6772                                };
6773
492
669
                                $rule->{stateless} = 1 if $stateless;
6774
492
660
                                $rule->{deny}      = 1 if $deny;
6775
492
637
                                $rule->{src_range} = $src_range if $src_range;
6776
492
988
                                $rule->{log}       = $log if $log;
6777
492
666
                                $rule->{orig_prt}  = $orig_prt if $orig_prt;
6778
492
1036
                                $rule->{oneway}    = 1 if $flags->{oneway};
6779
492
645
                                $rule->{no_check_supernet_rules} = 1
6780                                  if $flags->{no_check_supernet_rules};
6781
492
668
                                $rule->{stateless_icmp} = 1
6782                                  if $flags->{stateless_icmp};
6783
6784
492
2516
                                push @$result, $rule;
6785                            }
6786                        }
6787                    }
6788                }
6789            }
6790        }
6791    }
6792
261
420
    show_unenforceable($service);
6793
6794    # Result is returned indirectly using parameter $result.
6795
261
508
    return;
6796}
6797
6798sub print_rulecount  {
6799
302
0
260
    my $count = 0;
6800
302
674
    for my $type ('deny', 'supernet', 'permit') {
6801
906
834
906
1023
1305
1266
        $count += grep { not $_->{deleted} } @{ $expanded_rules{$type} };
6802    }
6803
302
651
    info("Expanded rule count: $count");
6804
302
284
    return;
6805}
6806
6807sub split_expanded_rule_types {
6808
315
0
296
    my ($rules_aref) = @_;
6809
6810
315
241
    my (@deny, @permit, @supernet);
6811
6812
315
380
    for my $rule (@$rules_aref) {
6813
492
1713
        if ($rule->{deny}) {
6814
2
3
            push @deny, $rule;
6815        }
6816        elsif ($rule->{src}->{is_supernet} || $rule->{dst}->{is_supernet}) {
6817
125
188
            push @supernet, $rule;
6818        }
6819        else {
6820
365
494
            push @permit, $rule;
6821        }
6822    }
6823
6824
315
1274
    %expanded_rules = (deny => \@deny,
6825                       permit => \@permit,
6826                       supernet => \@supernet);
6827
315
442
    return;
6828}
6829
6830sub expand_services {
6831
315
0
328
    my ($convert_hosts) = @_;
6832
315
693
    convert_hosts if $convert_hosts;
6833
315
404
    progress('Expanding services');
6834
6835
315
449
    collect_log();
6836
315
354
    my $expanded_rules_aref = [];
6837
6838    # Sort by service name to make output deterministic.
6839
315
647
    for my $key (sort keys %services) {
6840
261
337
        my $service = $services{$key};
6841
261
290
        my $name    = $service->{name};
6842
6843        # Substitute service name by service object.
6844
261
460
        if (my $overlaps = $service->{overlaps}) {
6845
4
8
            my @pobjects;
6846
4
6
            for my $pair (@$overlaps) {
6847
4
6
                my ($type, $oname) = @$pair;
6848
4
15
                if (! $type eq 'service') {
6849
0
0
                    err_msg "Unexpected type '$type' in attribute 'overlaps'",
6850                      " of $name";
6851                }
6852                elsif (my $other = $services{$oname}) {
6853
4
12
                    push(@pobjects, $other);
6854                }
6855                else {
6856
0
0
                    warn_msg("Unknown $type:$oname in attribute 'overlaps'",
6857                             " of $name");
6858                }
6859            }
6860
4
7
            $service->{overlaps} = \@pobjects;
6861        }
6862
6863        # Attribute "visible" is known to have value "*" or "name*".
6864        # It must match prefix of some owner name.
6865        # Change value to regex to simplify tests: # name* -> /^name.*$/
6866
261
443
        if (my $visible = $service->{visible}) {
6867
0
0
            if (my ($prefix) = ($visible =~ /^ (\S*) [*] $/x)) {
6868
0
0
                if ($prefix) {
6869
0
0
0
0
                    if (not grep { /^$prefix/ } keys %owners) {
6870
0
0
                        warn_msg("Attribute 'visible' of $name doesn't match",
6871                                 " any owner");
6872                    }
6873                }
6874
0
0
                $service->{visible} = qr/^$prefix.*$/;
6875            }
6876        }
6877
6878        # Don't convert hosts in user objects here.
6879        # This will be done when expanding 'user' inside a rule.
6880
261
596
        $service->{user} = expand_group($service->{user}, "user of $name");
6881
261
638
        expand_rules($service, $expanded_rules_aref, $convert_hosts);
6882    }
6883
6884
315
484
    warn_useless_unenforceable();
6885
315
487
    info("Expanded rule count: ", scalar @$expanded_rules_aref);
6886
6887
315
392
    progress('Preparing optimization');
6888
315
754
    add_rules($expanded_rules_aref);
6889
492
873
    info("Expanded rule count: ",
6890
315
413
         scalar grep { !$_->{deleted} } @$expanded_rules_aref);
6891
315
432
    show_deleted_rules1();
6892
6893    # Set attribute {is_supernet} before calling split_expanded_rule_types.
6894
315
399
    find_subnets_in_nat_domain();
6895
315
444
    split_expanded_rule_types($expanded_rules_aref);
6896
315
349
    return;
6897}
6898
6899# For each device, find the IP address which is used
6900# to manage the device from a central policy distribution point.
6901# This address is added as a comment line to each generated code file.
6902# This is to be used later when approving the generated code file.
6903sub set_policy_distribution_ip  {
6904
226
0
294
    progress('Setting policy distribution IP');
6905
6906    # Find all TCP ranges which include port 22 and 23.
6907
429
1014
    my @admin_tcp_keys = grep({
6908
226
469
            my ($p1, $p2) = split(':', $_);
6909
429
2062
              $p1 <= 22 && 22 <= $p2 || $p1 <= 23 && 23 <= $p2;
6910        }
6911
226
197
        keys %{ $prt_hash{tcp} });
6912
226
226
274
408
    my @prt_list = (@{ $prt_hash{tcp} }{@admin_tcp_keys}, $prt_hash{ip});
6913
6914    # Mapping from policy distribution host to subnets, networks and
6915    # aggregates that include this host.
6916
226
183
    my %host2pdp_src;
6917    my $get_pdp_src = sub {
6918
10
9
        my ($host) = @_;
6919
10
8
        my $pdp_src;
6920
10
27
        if ($pdp_src = $host2pdp_src{$host}) {
6921
1
1
            return $pdp_src;
6922        }
6923
9
9
9
9
17
12
        for my $pdp (map { $_ } @{ $host->{subnets} }) {
6924
9
16
            while ($pdp) {
6925
18
24
                push @$pdp_src, $pdp;
6926
18
35
                $pdp = $pdp->{up};
6927            }
6928        }
6929
9
22
        return $host2pdp_src{$host} = $pdp_src;
6930
226
645
    };
6931
226
331
    for my $router (@managed_routers, @routing_only_routers) {
6932
365
789
        my $pdp = $router->{policy_distribution_point} or next;
6933
10
20
        next if $router->{orig_router};
6934
6935
10
12
        my %found_interfaces;
6936
10
16
        my $no_nat_set = $pdp->{network}->{nat_domain}->{no_nat_set};
6937
10
18
        my $pdp_src    = $get_pdp_src->($pdp);
6938
10
12
        my $stateless  = '';
6939
10
9
        my $deny       = '';
6940
10
11
        my $src_range  = $prt_ip;
6941
10
12
        for my $src (@$pdp_src) {
6942
20
63
            my $sub_rule_tree =
6943                $rule_tree{$stateless}->{$deny}->{$src_range}->{$src} or next;
6944
6945            # Find interfaces where some rule permits management traffic.
6946
8
8
7
14
            for my $interface (@{ $router->{interfaces} }) {
6947
6948                # Loadbalancer VIP can't be used to access device.
6949
18
30
                next if $interface->{vip};
6950
6951
18
20
                for my $prt (@prt_list) {
6952
54
136
                    $sub_rule_tree->{$interface}->{$prt} or next;
6953
9
24
                    $found_interfaces{$interface} = $interface;
6954                }
6955            }
6956        }
6957
10
11
        my @result;
6958
6959        # Ready, if exactly one management interface was found.
6960
10
27
        if (keys %found_interfaces == 1) {
6961
7
10
            @result = values %found_interfaces;
6962        }
6963        else {
6964
6965#           debug("$router->{name}: ", scalar keys %found_interfaces);
6966
3
5
            my @front = path_auto_interfaces($router, $pdp);
6967
6968            # If multiple management interfaces were found, take that which is
6969            # directed to policy_distribution_point.
6970
3
5
            for my $front (@front) {
6971
4
11
                if ($found_interfaces{$front}) {
6972
2
2
                    push @result, $front;
6973                }
6974            }
6975
6976            # Take all management interfaces.
6977            # Preserve original order of router interfaces.
6978
3
6
            if (! @result) {
6979
2
4
2
2
10
3
                @result = grep { $found_interfaces{$_} } @{ $router->{interfaces} };
6980            }
6981
6982            # Don't set {admin_ip} if no address is found.
6983            # Warning is printed below.
6984
3
9
            next if not @result;
6985        }
6986
6987        # Prefer loopback interface if available.
6988
9
23
        $router->{admin_ip} = [
6989
1
8
            map { print_ip((address($_, $no_nat_set))->[0]) }
6990
8
14
            sort { ($b->{loopback} || '') cmp($a->{loopback} || '') } @result
6991        ];
6992    }
6993
226
241
    my %seen;
6994    my @unreachable;
6995
226
268
    for my $router (@managed_routers, @routing_only_routers) {
6996
365
655
        next if $seen{$router};
6997
364
693
        next if !$router->{policy_distribution_point};
6998
9
18
        next if $router->{orig_router};
6999
9
16
        if (my $vrf_members = $router->{vrf_members}) {
7000
1
2
            for my $member (@$vrf_members) {
7001
1
5
                if (!$member->{admin_ip}) {
7002
1
3
                    push(@unreachable,
7003                         "some VRF of router:$router->{device_name}");
7004
1
1
                    last;
7005                }
7006            }
7007
7008            # Print VRF instance with known admin_ip first.
7009
1
5
            $router->{vrf_members} = [
7010                sort {
7011
1
2
                    !$a->{admin_ip} <=> !$b->{admin_ip}
7012                    || $a->{name} cmp $b->{name}
7013                  } @$vrf_members
7014            ];
7015
1
4
            $seen{$_} = 1 for @$vrf_members;
7016        }
7017        else {
7018
8
15
            $router->{admin_ip}
7019              or push @unreachable, $router->{name};
7020
8
22
            $seen{$router} = 1;
7021        }
7022    }
7023
226
381
    if (@unreachable) {
7024
1
2
        if (@unreachable > 4) {
7025
0
0
            splice(@unreachable, 3, @unreachable - 3, '...');
7026        }
7027
1
3
        my $list = join("\n - ", @unreachable);
7028
1
2
        warn_msg (
7029            "Missing rules to reach devices from policy_distribution_point:\n",
7030            " - ", $list);
7031    }
7032
226
983
    return;
7033}
7034
7035##############################################################################
7036# Distribute owner, identify service owner
7037##############################################################################
7038
7039sub propagate_owners {
7040
311
0
274
    my %zone_got_net_owners;
7041    my %clusters;
7042  ZONE:
7043
311
327
    for my $zone (@zones) {
7044
824
1242
        if (my $cluster = $zone->{zone_cluster}) {
7045
44
73
            $clusters{$cluster} = $cluster;
7046        }
7047
7048        # If an explicit owner was set, it has been set for
7049        # the whole cluster in link_aggregates.
7050
824
1449
        next if $zone->{owner};
7051
7052        # Inversed inheritance: If a zone has no direct owner and if
7053        # all contained real toplevel networks have the same owner,
7054        # then set owner of this zone to the one owner.
7055
815
577
        my $owner;
7056
815
815
595
927
        for my $network (@{ $zone->{networks} }) {
7057
807
1206
            next if $network->{ip} eq 'tunnel';
7058
807
655
            my $net_owner = $network->{owner};
7059
807
1599
            next ZONE if not $net_owner;
7060
10
16
            if ($owner) {
7061
1
3
                next ZONE if $net_owner ne $owner;
7062            }
7063            else {
7064
9
14
                $owner = $net_owner;
7065            }
7066        }
7067
17
37
        if ($owner) {
7068#            debug("Inversed inherit: $zone->{name} $owner->{name}");
7069
8
8
            $zone->{owner} = $owner;
7070
8
17
            $zone_got_net_owners{$zone} = 1;
7071        }
7072    }
7073
7074    # Check for consistent implicit owners of zone clusters.
7075    # Implicit owner from networks is only valid, if the same owner
7076    # is found for all zones of cluster.
7077
311
528
    for my $cluster (values %clusters) {
7078
18
44
23
97
        my @implicit_owner_zones = grep { $zone_got_net_owners{$_} } @$cluster
7079            or next;
7080
0
0
        if (
7081            !(
7082
0
0
                @implicit_owner_zones == @$cluster
7083                && equal(map { $_->{owner} } @implicit_owner_zones)
7084            )
7085          )
7086        {
7087
0
0
            $_->{owner} = undef for @implicit_owner_zones;
7088
7089#            debug("Reset owner");
7090#            debug($_->{name}) for @implicit_owner_zones;
7091        }
7092    }
7093
7094    # A zone can be part of multiple areas.
7095    # Find the smallest enclosing area.
7096
311
267
    my %zone2area;
7097
311
337
    for my $zone (@zones) {
7098
824
824
606
2228
        my @areas = values %{ $zone->{areas} } or next;
7099
82
32
32
32
92
27
33
40
        @areas = sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas;
7100
82
162
        $zone2area{$zone} = $areas[0];
7101    }
7102
7103    # Build tree from inheritance relation:
7104    # area -> [area|zone, ..]
7105    # zone  -> [network, ..]
7106    # network -> [network, ..]
7107    # network -> [host|interface, ..]
7108
311
307
    my %tree;
7109    my %is_child;
7110
0
0
    my %ref2obj;
7111    my $add_node = sub {
7112
1697
1503
        my ($super, $sub) = @_;
7113
1697
1697
1189
3132
        push @{ $tree{$super} }, $sub;
7114
1697
2517
        $is_child{$sub}  = 1;
7115
1697
2138
        $ref2obj{$sub}   = $sub;
7116
1697
2923
        $ref2obj{$super} = $super;
7117
311
988
    };
7118
7119    # Find subset relation between areas.
7120
311
404
    for my $area (@areas) {
7121
59
133
        if (my $super = $area->{subset_of}) {
7122
16
27
            $add_node->($super, $area);
7123        }
7124    }
7125
7126    # Find direct subset relation between areas and zones.
7127
311
352
    for my $area (@areas) {
7128
59
59
56
77
        for my $zone (@{ $area->{zones} }) {
7129
110
258
            if ($zone2area{$zone} eq $area) {
7130
82
101
                $add_node->($area, $zone);
7131            }
7132        }
7133    }
7134
7135    # Find subset relation between networks and hosts/interfaces.
7136    my $add_hosts = sub {
7137
1007
789
        my ($network) = @_;
7138
1007
1007
716
1362
        for my $host (@{ $network->{hosts} }) {
7139
149
173
            $add_node->($network, $host);
7140        }
7141
1007
1007
818
1120
        for my $interface (@{ $network->{interfaces} }) {
7142
1454
1233
            my $router = $interface->{router};
7143
1454
3724
            if (!($router->{managed} || $router->{routing_only})) {
7144
443
550
                $add_node->($network, $interface);
7145            }
7146        }
7147
311
791
    };
7148
7149    # Find subset relation between networks and networks.
7150
311
272
    my $add_subnets;
7151    $add_subnets = sub {
7152
1007
818
        my ($network) = @_;
7153
1007
1087
        $add_hosts->($network);
7154
1007
2637
        my $subnets = $network->{networks} or return;
7155
50
76
        for my $subnet (@$subnets) {
7156
52
59
            $add_node->($network, $subnet);
7157
52
118
            $add_subnets->($subnet);
7158        }
7159
311
726
    };
7160
7161    # Find subset relation between zones and networks.
7162
311
344
    for my $zone (@zones) {
7163
824
824
636
964
        for my $network (@{ $zone->{networks} }) {
7164
955
1114
            $add_node->($zone, $network);
7165
955
1077
            $add_subnets->($network);
7166        }
7167    }
7168
7169    # Find root nodes.
7170
775
1321
    my @root_nodes =
7171
311
1330
722
1785
        sort by_name map { $ref2obj{$_} } grep { not $is_child{$_} } keys %tree;
7172
7173    # owner is extended by e_owner at node.
7174    # owner->[[node, e_owner, .. ], .. ]
7175
311
377
    my %extended;
7176
7177    # upper_owner: owner object without attribute extend_only or undef
7178    # extend: a list of owners with attribute extend
7179    # extend_only: a list of owners with attribute extend_only
7180    my $inherit;
7181    $inherit = sub {
7182
2472
2410
        my ($node, $upper_owner, $upper_node, $extend, $extend_only) = @_;
7183
2472
2112
        my $owner = $node->{owner};
7184
2472
2643
        if (!$owner) {
7185
2406
2539
            $node->{owner} = $upper_owner;
7186        }
7187        else {
7188
66
66
            $owner->{is_used} = 1;
7189
66
102
            if ($upper_owner) {
7190
36
69
                if ($owner eq $upper_owner) {
7191
13
26
                    if (! $zone_got_net_owners{$upper_node})
7192                    {
7193
5
23
                        warn_msg("Useless $owner->{name} at $node->{name},\n",
7194                                 " it was already inherited from",
7195                                 " $upper_node->{name}");
7196                    }
7197                }
7198                else {
7199
23
43
                    if ($upper_owner->{extend}) {
7200
3
5
                        $extend = [ $upper_owner, @$extend ];
7201                    }
7202                }
7203            }
7204
66
78
            my @extend_list = ($node);
7205
66
99
            push @extend_list, @$extend if $extend;
7206
66
94
            push @extend_list, @$extend_only if $extend_only;
7207
66
66
48
138
            push @{ $extended{$owner} }, \@extend_list;
7208        }
7209
2472
3908
        if (!$owner || !$owner->{extend_only}) {
7210
2466
3514
            if (my $upper_extend = $extend_only->[0]) {
7211
20
22
                $node->{extended_owner} = $upper_extend;
7212            }
7213        }
7214
7215
2472
5197
        if ($owner && $owner->{extend_only}) {
7216
6
7
            $extend_only = [ $owner, @$extend_only ];
7217
6
6
            $upper_owner = undef;
7218
6
6
            $upper_node  = undef;
7219        }
7220        elsif($owner) {
7221
60
47
            $upper_owner = $owner;
7222
60
53
            $upper_node  = $node;
7223        }
7224
2472
6684
        my $childs = $tree{$node} or return;
7225
1330
1318
        for my $child (@$childs) {
7226
1697
3042
            $inherit->($child, $upper_owner, $upper_node, $extend,
7227                $extend_only);
7228        }
7229
311
1277
    };
7230
311
379
    for my $node (@root_nodes) {
7231
775
1219
        $inherit->($node, undef, undef, [], []);
7232    }
7233
7234    # Collect extended owners and check for inconsistent extensions.
7235    # Check owner with attribute {show_all}.
7236
311
783
    for my $owner (sort by_name values %owners) {
7237
48
108
        my $aref = $extended{$owner} || [];
7238
48
44
        my $node1;
7239        my $ext1;
7240
0
0
        my $combined;
7241
48
51
        for my $node_ext (@$aref) {
7242
66
65
            my $node = shift @$node_ext;
7243
66
118
            next if $zone_got_net_owners{$node};
7244
58
46
            my $ext = $node_ext;
7245
58
74
            if ($node1) {
7246
14
19
                for my $owner_list ($ext1, $ext) {
7247
28
60
                    my ($other, $owner_node, $other_node) =
7248                          $owner_list eq $ext
7249                        ? ($ext1, $node, $node1)
7250                        : ($ext, $node1, $node);
7251
28
46
                    for my $e_owner (@$owner_list) {
7252
6
13
                        next if $e_owner->{extend_unbounded};
7253
5
6
5
15
                        next if grep { $e_owner eq $_ } @$other;
7254
5
23
                        warn_msg("$owner->{name}",
7255                                 " is extended by $e_owner->{name}\n",
7256                                 " - only at $owner_node->{name}\n",
7257                                 " - but not at $other_node->{name}");
7258                    }
7259                }
7260
14
30
                $combined = [ @$ext, @$combined ];
7261            }
7262            else {
7263
44
33
                $combined = $ext;
7264
44
75
                ($node1, $ext1) = ($node, $ext);
7265            }
7266        }
7267
48
155
        if ($combined && @$combined) {
7268
10
15
            $owner->{extended_by} = [ unique @$combined ];
7269        }
7270
48
117
        if ($owner->{show_all}) {
7271
1
1
            my @invalid;
7272
1
1
            for my $node (@root_nodes) {
7273
3
9
                my $node_owner = $node->{owner} || '';
7274
3
6
                if ($node_owner ne $owner) {
7275
2
2
                    push @invalid, $node;
7276                }
7277            }
7278
1
2
            if (@invalid) {
7279
1
2
2
4
                my $missing = join("\n - ", map { $_->{name} } @invalid);
7280
1
4
                err_msg("$owner->{name} has attribute 'show_all',",
7281                        " but doesn't own whole topology.\n",
7282                        " Missing:\n",
7283                        " - $missing");
7284            }
7285        }
7286    }
7287
7288    # Handle {router_attributes}->{owner} separately.
7289    # Areas can be nested. Proceed from small to larger ones.
7290
311
28
28
28
523
26
30
41
    for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) {
7291
59
127
        my $attributes = $area->{router_attributes} or next;
7292
7
17
        my $owner = $attributes->{owner} or next;
7293
0
0
        $owner->{is_used} = 1;
7294
0
0
0
0
        for my $router (@{ $area->{managed_routers} }) {
7295
0
0
            if (my $r_owner = $router->{owner}) {
7296
0
0
                if ($r_owner eq $owner) {
7297
0
0
                    warn_msg(
7298                        "Useless $r_owner->{name} at $router->{name},\n",
7299                        " it was already inherited from $attributes->{name}");
7300                }
7301            }
7302            else {
7303
0
0
                $router->{owner} = $owner;
7304            }
7305        }
7306    }
7307
7308
311
400
    for my $router (@managed_routers, @routing_only_routers) {
7309
454
897
        my $owner = $router->{owner} or next;
7310
1
2
        $owner->{is_used} = 1;
7311
7312
1
2
        for my $interface (get_intf($router)) {
7313
7314            # Loadbalancer interface with {vip} can have dedicated owner.
7315
3
9
            $interface->{owner} ||= $owner;
7316        }
7317    }
7318
7319    # Propagate owner of loopback interface to loopback network
7320    # and loopback zone.
7321
311
369
    for my $router (@routers) {
7322
634
1245
        my $managed = $router->{managed} || $router->{routing_only};
7323
634
634
470
757
        for my $interface (@{ $router->{interfaces} }) {
7324
1498
2664
            $interface->{loopback} or next;
7325
39
82
            my $owner = $interface->{owner} or next;
7326
1
1
            my $network = $interface->{network};
7327
1
2
            $network->{owner} = $owner;
7328
1
2
            $network->{zone}->{owner} = $owner if $managed;
7329
7330            # Mark dedicated owner of {vip} interface, which is also a
7331            # loopback interface.
7332
1
2
            $owner->{is_used} = 1;
7333        }
7334    }
7335
7336    # Inherit owner from enclosing network or zone to aggregate.
7337
311
341
    for my $zone (@zones) {
7338
824
824
617
1536
        for my $aggregate (values %{ $zone->{ipmask2aggregate} }) {
7339
49
96
            next if $aggregate->{owner};
7340
49
41
            my $up = $aggregate;
7341
49
100
            while ($up = $up->{up}) {
7342
17
31
                last if !$up->{is_aggregate};
7343            }
7344
49
123
            $aggregate->{owner} = ($up ? $up : $zone)->{owner};
7345        }
7346    }
7347
311
748
    return;
7348}
7349
7350sub expand_auto_intf {
7351
514
0
474
    my ($src_aref, $dst_aref) = @_;
7352
514
861
    for (my $i = 0 ; $i < @$src_aref ; $i++) {
7353
703
586
        my $src = $src_aref->[$i];
7354
703
774
        next if not is_autointerface($src);
7355
23
21
        my @new;
7356
23
27
        for my $dst (@$dst_aref) {
7357
26
40
            push @new, path_auto_interfaces($src, $dst);
7358        }
7359
7360        # Substitute auto interface by real interface(s).
7361        # Possible duplicate elements in @new are removed later.
7362
23
67
        splice(@$src_aref, $i, 1, @new);
7363    }
7364
514
520
    return;
7365}
7366
7367my %unknown2services;
7368my %unknown2unknown;
7369
7370sub show_unknown_owners {
7371
311
0
495
    for my $polices (values %unknown2services) {
7372
0
0
        $polices = join(',', sort @$polices);
7373    }
7374
311
667
    my $print =
7375      $config{check_service_unknown_owner} eq 'warn'
7376      ? \&warn_msg
7377      : \&err_msg;
7378  UNKNOWN:
7379
311
492
    for my $obj (values %unknown2unknown) {
7380
0
0
        my $up = $obj;
7381
0
0
        while ($up = $up->{up}) {
7382
0
0
            if (    $unknown2services{$up}
7383                and $unknown2services{$obj} eq $unknown2services{$up})
7384            {
7385
0
0
                next UNKNOWN;
7386            }
7387        }
7388
0
0
        $print->("Unknown owner for $obj->{name} in $unknown2services{$obj}");
7389    }
7390
311
476
    %unknown2services = %unknown2unknown = ();
7391
311
299
    return;
7392}
7393
7394sub set_service_owner {
7395
311
0
390
    progress('Checking service owner');
7396
7397
311
419
    propagate_owners();
7398
7399
311
627
    for my $key (sort keys %services) {
7400
257
378
        my $service = $services{$key};
7401
257
270
        my $sname   = $service->{name};
7402
7403
257
647
        my $users = expand_group($service->{user}, "user of $sname");
7404
7405        # Non 'user' objects.
7406
257
241
        my @objects;
7407
7408        # Check, if service contains a coupling rule with only "user" elements.
7409
257
223
        my $is_coupling = 0;
7410
7411
257
257
221
362
        for my $rule (@{ $service->{rules} }) {
7412
291
302
            my $has_user = $rule->{has_user};
7413
291
462
            if ($has_user eq 'both') {
7414
11
12
                $is_coupling = 1;
7415
11
19
                next;
7416            }
7417
280
287
            for my $what (qw(src dst)) {
7418
560
902
                next if $what eq $has_user;
7419
280
648
                push(@objects,
7420
280
219
                    @{ expand_group($rule->{$what}, "$what of $sname") });
7421            }
7422        }
7423
7424        # Expand auto interface of objects in rules to set of real interfaces.
7425
257
432
        expand_auto_intf(\@objects, $users);
7426
7427        # Expand auto interfaces in users with counterpart in
7428        # - users and objects
7429        # - only users
7430        # - only objects.
7431        # Add elements of expanded users to objects.
7432
257
363
        if ($is_coupling) {
7433
11
21
            if (@objects) {
7434
0
0
                expand_auto_intf($users, [ @objects, @$users ]);
7435            }
7436            else {
7437
11
19
                expand_auto_intf($users, $users);
7438            }
7439
11
14
            push @objects, @$users;
7440        }
7441        else {
7442
246
311
            expand_auto_intf($users, \@objects);
7443        }
7444
7445        # Collect service owners and unknown owners;
7446
257
232
        my $service_owners;
7447        my $unknown_owners;
7448
7449
257
368
        for my $obj (unique @objects) {
7450
307
319
            my $owner = $obj->{owner};
7451
307
741
            if ($owner) {
7452
15
35
                $service_owners->{$owner} = $owner;
7453            }
7454            else {
7455
292
657
                $unknown_owners->{$obj} = $obj;
7456            }
7457        }
7458
7459
257
547
        $service->{owners} = [ values %$service_owners ];
7460
7461        # Check for redundant service owner.
7462        # Allow dedicated service owner, if we have multiple owners
7463        # from @objects.
7464
257
474
        if (my $sub_owner = $service->{sub_owner}) {
7465
1
1
            $sub_owner->{is_used} = 1;
7466
1
3
            (keys %$service_owners == 1 && $service_owners->{$sub_owner}) and
7467                warn_msg("Useless $sub_owner->{name} at $service->{name}");
7468        }
7469
7470        # Check for multiple owners.
7471
257
397
        my $multi_count =
7472          $is_coupling
7473          ? 1
7474          : values %$service_owners;
7475
257
924
        if ($multi_count > 1 xor $service->{multi_owner}) {
7476
1
3
            if ($service->{multi_owner}) {
7477
0
0
                warn_msg("Useless use of attribute 'multi_owner' at $sname");
7478            }
7479            else {
7480                my $print =
7481                    $config{check_service_multi_owner}
7482                  ? $config{check_service_multi_owner} eq 'warn'
7483                      ? \&warn_msg
7484                      : \&err_msg
7485
1
0
4
0
                  : sub { };
7486
2
10
                my @names =
7487
1
2
                  sort(map { ($_->{name} =~ /^owner:(.*)/)[0] }
7488                      values %$service_owners);
7489
1
5
                $print->("$sname has multiple owners:\n " . join(', ', @names));
7490            }
7491        }
7492
7493        # Check for unknown owners.
7494
257
1353
        if (($unknown_owners and keys %$unknown_owners)
7495            xor $service->{unknown_owner})
7496        {
7497
246
319
            if ($service->{unknown_owner}) {
7498
0
0
                warn_msg("Useless use of attribute 'unknown_owner' at $sname");
7499            }
7500            else {
7501
246
1044
                if ($config{check_service_unknown_owner}) {
7502
0
0
                    for my $obj (values %$unknown_owners) {
7503
0
0
                        $unknown2unknown{$obj} = $obj;
7504
0
0
0
0
                        push @{ $unknown2services{$obj} }, $sname;
7505                    }
7506                }
7507            }
7508        }
7509    }
7510
7511    # Show unused owners.
7512    # Remove attribute {is_used}, which isn't needed any longer.
7513
311
557
    for my $owner (values %owners) {
7514
48
108
        delete $owner->{is_used} or warn_msg("Unused $owner->{name}");
7515    }
7516
7517
311
450
    show_unknown_owners();
7518
311
260
    return;
7519}
7520
7521##############################################################################
7522# Distribute NAT bindings
7523##############################################################################
7524
7525# NAT Set: a set of NAT tags which are effective at some location.
7526# NAT Domain: a maximal area of the topology (a set of connected networks)
7527# where the NAT set is identical at each network.
7528sub set_natdomain;
7529
7530sub set_natdomain {
7531
1243
0
1173
    my ($network, $domain, $in_interface) = @_;
7532
7533    # Found a loop inside a NAT domain.
7534
1243
2013
    return if $network->{nat_domain};
7535
7536#    debug("$domain->{name}: $network->{name}");
7537
1112
1511
    $network->{nat_domain} = $domain;
7538
1112
1112
835
1379
    push @{ $domain->{networks} }, $network;
7539
1112
1112
931
1343
    for my $interface (@{ $network->{interfaces} }) {
7540
7541        # Ignore interface where we reached this network.
7542
1630
3394
        next if $interface eq $in_interface;
7543
7544
961
1399
        next if $interface->{main_interface};
7545
7546#        debug("IN $interface->{name}");
7547
883
630
        my $err_seen;
7548
883
2112
        my $nat_tags = $interface->{bind_nat} || $bind_nat0;
7549
883
757
        my $router = $interface->{router};
7550
883
883
657
1077
        for my $out_interface (@{ $router->{interfaces} }) {
7551
7552            # Don't process interface where we reached this router.
7553
2128
4217
            next if $out_interface eq $interface;
7554
7555            # Current NAT domain continues behind $out_interface.
7556
1245
2827
            my $out_nat_tags = $out_interface->{bind_nat} || $bind_nat0;
7557
1245
1487
            if (aref_eq($out_nat_tags, $nat_tags)) {
7558
7559                # Put check for active path inside this loop, because
7560                # 1. we must enter each router from each side to detect
7561                #    all inconsistencies,
7562                # 2. we need the check at all to prevent deep recursion.
7563                #
7564                # 'local' declaration restores previous value on block exit.
7565
965
1426
                next if $router->{active_path};
7566
905
1109
                local $router->{active_path} = 1;
7567
7568
905
1377
                next if $out_interface->{main_interface};
7569
7570
800
705
                my $next_net = $out_interface->{network};
7571
800
1322
                set_natdomain($next_net, $domain, $out_interface);
7572            }
7573
7574            # New NAT domain starts at some interface of current router.
7575            # Remember NAT tag of current domain.
7576            else {
7577
7578                # If one router is connected to the same NAT domain
7579                # by different interfaces, all interfaces must have
7580                # the same NAT binding. (This occurs only in loops).
7581
280
604
                if (my $old_nat_tags = $router->{nat_tags}->{$domain}) {
7582
79
87
                    if (not aref_eq($old_nat_tags, $nat_tags)) {
7583
1
5
                        next if $err_seen->{$old_nat_tags}->{$nat_tags}++;
7584
1
4
                        my $old_names = join(',', @$old_nat_tags) || '(none)';
7585
1
5
                        my $new_names = join(',', @$nat_tags)     || '(none)';
7586
1
5
                        err_msg
7587                          "Inconsistent NAT in loop at $router->{name}:\n",
7588                          " nat:$old_names vs. nat:$new_names";
7589                    }
7590
7591                    # NAT domain and router have been linked together already.
7592
79
141
                    next;
7593                }
7594
201
347
                $router->{nat_tags}->{$domain} = $nat_tags;
7595#                debug("OUT $out_interface->{name}");
7596
201
201
152
233
                push @{ $domain->{routers} },     $router;
7597
201
201
173
442
                push @{ $router->{nat_domains} }, $domain;
7598            }
7599        }
7600    }
7601
1112
2185
    return;
7602}
7603
7604my @natdomains;
7605
7606# Distribute NAT tags from NAT domain to NAT domain.
7607# Returns
7608# - undef on success
7609# - aref of routers, if invalid path was found in loop.
7610sub distribute_nat1 {
7611
119
0
129
    my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_;
7612
7613#    debug "nat:$nat_tag at $domain->{name} from $in_router->{name}";
7614
119
196
    if ($domain->{active_path}) {
7615
7616#       debug("$domain->{name} loop");
7617        # Found a loop
7618
1
6
        return;
7619    }
7620
7621    # Tag is already there.
7622
118
108
    my $nat_set = $domain->{nat_set};
7623
118
198
    return if $nat_set->{$nat_tag};
7624
7625    # Must not enter one NAT domain at different routers with
7626    # different elements of grouped NAT tags.
7627
104
194
    if (my $aref = $nat_tags2multi->{$nat_tag}) {
7628
42
41
        for my $multi_href (@$aref) {
7629
51
107
            for my $nat_tag2 (sort keys %$multi_href) {
7630
119
236
                if ($nat_set->{$nat_tag2}) {
7631
2
9
                    err_msg("Grouped NAT tags '$nat_tag2' and '$nat_tag'",
7632                            " must not both be active inside $domain->{name}");
7633                }
7634            }
7635        }
7636    }        
7637
7638    # Add tag.
7639    # Use a hash to prevent duplicate entries.
7640
104
152
    $nat_set->{$nat_tag} = 1;
7641
7642    # Network which has translation with tag $nat_tag must not be located
7643    # in area where this tag is effective.
7644
104
104
89
147
    for my $network (@{ $domain->{networks} }) {
7645
133
280
        my $nat = $network->{nat} or next;
7646
6
13
        $nat->{$nat_tag} or next;
7647
1
8
        err_msg("$network->{name} is translated by $nat_tag,\n",
7648                " but is located inside the translation domain of $nat_tag.\n",
7649                " Probably $nat_tag was bound to wrong interface",
7650                " at $in_router->{name}.");
7651
7652        # Show error message only once.
7653
1
2
        last;
7654    }
7655
7656    # Activate loop detection.
7657
104
162
    local $in_router->{active_path} = 1;
7658
104
124
    local $domain->{active_path} = 1;
7659
7660    # Distribute NAT tag to adjacent NAT domains.
7661
104
104
91
127
    for my $router (@{ $domain->{routers} }) {
7662
136
321
        next if $router eq $in_router;
7663
33
37
        my $in_nat_tags = $router->{nat_tags}->{$domain};
7664
7665        # Found another interface with same NAT binding.
7666        # This stops effect of current NAT tag.
7667
33
14
50
42
        next if grep { $_ eq  $nat_tag } @$in_nat_tags;
7668
7669        # Traverse loop twice to prevent inherited errors.
7670        # Check for recursive and duplicate NAT.
7671
23
23
20
30
        for my $out_domain (@{ $router->{nat_domains} }) {
7672
51
85
            next if $out_domain eq $domain;
7673
29
40
            my $out_nat_tags = $router->{nat_tags}->{$out_domain};
7674
7675            # Must not apply one NAT tag multiple times in a row.
7676
29
25
32
70
            if (grep { $_ eq  $nat_tag } @$out_nat_tags) {
7677
7678                # Check for recursive NAT in loop.
7679
3
6
                if ($router->{active_path}) {
7680
7681                    # Abort traversal and start collecting path.
7682
1
5
                    return [ $router ];
7683                }
7684
2
9
                err_msg("nat:$nat_tag is applied twice between",
7685                        " $in_router->{name} and $router->{name}");
7686            }
7687        }
7688
7689      DOMAIN:
7690
22
22
19
28
        for my $out_domain (@{ $router->{nat_domains} }) {
7691
49
86
            next if $out_domain eq $domain;
7692
27
31
            my $out_nat_tags = $router->{nat_tags}->{$out_domain};
7693
7694            # Effect of current NAT tag stops if another element of
7695            # grouped NAT tags becomes active.
7696
27
52
            if (my $aref = $nat_tags2multi->{$nat_tag}) {
7697
21
21
                for my $href (@$aref) {
7698
22
25
                    for my $nat_tag2 (@$out_nat_tags) {
7699
20
26
                        next if $nat_tag2 eq $nat_tag;
7700
20
39
                        next if !$href->{$nat_tag2};
7701
7702#                        debug "- $nat_tag2";
7703                        # Prevent transition from dynamic to
7704                        # static NAT.
7705
16
14
                        my $nat_info = $href->{$nat_tag};
7706
16
16
                        my $next_info = $href->{$nat_tag2};
7707
7708                        # Use $next_info->{name} and not $nat_info->{name}
7709                        # because $nat_info may show wrong network,
7710                        # because we combined different hidden networks into
7711                        # $nat_tags2multi.
7712
16
27
                        if ($nat_info->{hidden}) {
7713
3
14
                            err_msg("Must not change hidden nat:$nat_tag",
7714                                    " using nat:$nat_tag2\n",
7715                                    " for $next_info->{name}",
7716                                    " at $router->{name}");
7717                        }
7718                        elsif ($nat_info->{dynamic}) {
7719
0
0
                            if(!($next_info->{dynamic})) {
7720
0
0
                                err_msg("Must not change dynamic nat:$nat_tag",
7721                                        " to static using nat:$nat_tag2\n",
7722                                        " for $nat_info->{name}",
7723                                        " at $router->{name}");
7724                            }
7725                        }
7726
16
46
                        next DOMAIN;
7727                    }
7728                }
7729            }
7730
7731#            debug "Caller $domain->{name}";
7732
11
29
            if (my $err_path = distribute_nat1($out_domain, $nat_tag,
7733                                               $nat_tags2multi, $router))
7734            {
7735
1
1
                push @$err_path, $router;
7736
1
4
                return $err_path;
7737            }
7738        }
7739    }
7740
102
286
    return;
7741}
7742
7743sub distribute_nat {
7744
108
0
137
    my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_;
7745
108
138
    if (my $err_path = distribute_nat1($domain, $nat_tag,
7746                                       $nat_tags2multi, $in_router)) {
7747
1
1
        push @$err_path, $in_router;
7748
3
6
        err_msg("nat:$nat_tag is applied recursively in loop at this path:\n",
7749
1
4
                " - ", join("\n - ", map { $_->{name} } reverse @$err_path));
7750    }
7751
108
108
    return;
7752}
7753
7754sub distribute_nat_info {
7755
332
0
474
    progress('Distributing NAT');
7756
7757    # Mapping from nat_tag to boolean. Is false if all NAT mappings map
7758    # to hidden.
7759
332
269
    my %has_non_hidden;
7760
7761
332
366
    for my $network (@networks) {
7762
1165
1978
        my $href = $network->{nat} or next;
7763
109
178
        for my $nat_tag (keys %$href) {
7764
128
131
            my $nat_network = $href->{$nat_tag};
7765
128
219
            if (!$nat_network->{hidden}) {
7766
91
192
                $has_non_hidden{$nat_tag} = 1;
7767            }
7768        }
7769    }
7770
7771    # A hash with all defined NAT tags.
7772    # It is used to check,
7773    # - if all NAT definitions are bound and
7774    # - if all bound NAT tags are defined somewhere.
7775
332
336
    my %nat_definitions;
7776
7777    # Check consistency of grouped NAT tags at one network.
7778    # If NAT tags are grouped at one network,
7779    # the same NAT tags must be used as group at all other networks.
7780    # Suppose tags A and B are used grouped.
7781    # An occurence of bind_nat = A activates NAT:A.
7782    # An successive bind_nat = B actives NAT:B, but implicitly disables NAT:A.
7783    # Hence A is disabled for all networks and therefore
7784    # this restriction is needed.
7785    # Exception:
7786    # NAT tags with "hidden" can be added to some valid set of grouped tags,
7787    # because we don't allow transition from hidden tag back to some other
7788    # (hidden) tag.
7789    #
7790    # A hash with all defined NAT tags as keys and aref of hrefs as value.
7791    # The href has those NAT tags as keys which are used together at one
7792    # network.
7793    # This is used to check,
7794    # that NAT tags are equally used grouped or solitary.
7795    my %nat_tags2multi;
7796
0
0
    my %all_hidden;
7797
332
345
    for my $network (@networks) {
7798
1165
1908
        my $href = $network->{nat} or next;
7799#        debug $network->{name}, " href=", join(',', sort keys %$href);
7800
7801        # Print error message only once per network.
7802
109
80
        my $err_shown;
7803        my $show_err = sub {
7804
5
6
            my ($href1, $href2) = @_;
7805
5
8
            return if $err_shown;
7806
3
7
            my $tags1  = join(',', sort keys %$href1);
7807
3
5
            my $name1  = $network->{name};
7808
3
8
            my $tags2  = join(',', sort keys %$href2);
7809
7810            # Values are NAT entries with name of network.
7811            # Take first value deterministically.
7812
3
7
5
11
            my ($name2) = sort map { $_->{name} } values %$href2;
7813
3
15
            err_msg
7814                "If multiple NAT tags are used at one network,\n",
7815                " these NAT tags must be used",
7816                " equally grouped at other networks:\n",
7817                " - $name1: $tags1\n",
7818                " - $name2: $tags2";
7819
3
4
            $err_shown = 1;
7820
3
4
            return;
7821
109
388
        };
7822
7823      NAT_TAG:
7824
109
241
        for my $nat_tag (sort keys %$href) {
7825
128
160
            $nat_definitions{$nat_tag} = 1;
7826
128
236
            if (my $aref = $nat_tags2multi{$nat_tag}) {
7827
7828                # If elements have a common non hidden tag,
7829                # then only a single href is allowed.
7830
31
61
                if ($has_non_hidden{$nat_tag}) {
7831
18
18
                    my $href2 = $aref->[0];
7832
18
28
                    keys_eq($href, $href2) or $show_err->($href, $href2);
7833
18
82
                    next NAT_TAG;
7834                }
7835
7836                # Array of hrefs has common hidden NAT tag.
7837                #
7838                # Ignore new href if it is identical to some previous one.
7839
13
14
                for my $href2 (@$aref) {
7840
18
20
                    keys_eq($href, $href2) and next NAT_TAG;
7841                }
7842
7843                # Some element is non hidden, check detailed.
7844
11
56
18
76
                if (grep { $has_non_hidden{$_} } %$href) {
7845
7846                    # Check new href for consistency with previous hrefs.
7847
8
18
                    for my $nat_tag2 (sort keys %$href) {
7848
22
32
                        next if $nat_tag2 eq $nat_tag;
7849
14
20
                        for my $href2 (@$aref) {
7850
7851                            # Don't check previous href with all hidden tags.
7852
25
42
                            next if $all_hidden{$href2};
7853
7854                            # Non hidden tag must not occur in other href.
7855
19
24
                            if ($has_non_hidden{$nat_tag2}) {
7856
13
29
                                if ($href2->{$nat_tag2}) {
7857
1
3
                                    $show_err->($href, $href2);
7858                                    next NAT_TAG
7859
1
2
                                }
7860                            }
7861
7862                            # Hidden tag must occur in all other hrefs.
7863                            else {
7864
6
15
                                if (!$href2->{$nat_tag2}) {
7865
0
0
                                    $show_err->($href, $href2);
7866                                    next NAT_TAG
7867
0
0
                                }
7868                            }
7869                        }
7870                    }
7871                }
7872
7873                # All elements are hidden. Always ok.
7874                else {
7875
7876                    # Mark this type of href for easier checks.
7877
3
5
                    $all_hidden{$href} = 1;
7878                }
7879
7880                # If current href and some previous href are in subset
7881                # relation, then take larger set.
7882
10
14
                for my $href2 (@$aref) {
7883
14
40
19
47
                    my $common_size = grep { $href2->{$_ } } keys %$href;
7884
14
39
                    if ($common_size eq keys %$href) {
7885
7886                        # Ignore new href, because it is subset.
7887
1
6
                        next NAT_TAG;
7888                    }
7889                    elsif ($common_size eq keys %$href2) {
7890
7891                        # Replace previous href by new superset.
7892
0
0
                        $href2 = $href;
7893
0
0
                        next NAT_TAG;
7894                    }
7895                    else {
7896
7897                        # Add new href below.
7898                    }
7899                }
7900            }
7901
106
106
98
555
            push @{ $nat_tags2multi{$nat_tag} }, $href;
7902        }
7903    }
7904
7905    # Remove single entries.
7906
332
578
    for my $nat_tag (keys %nat_tags2multi) {
7907
97
106
        my $aref = $nat_tags2multi{$nat_tag};
7908
97
157
        next if @$aref > 1;
7909
91
88
        my $href = $aref->[0];
7910
91
144
        next if keys %$href > 1;
7911
59
134
        delete $nat_tags2multi{$nat_tag};
7912    }
7913
7914    # Find NAT domains.
7915
332
388
    for my $network (@networks) {
7916
1165
1696
        next if $network->{is_aggregate};
7917
1112
1777
        next if $network->{nat_domain};
7918
443
2306
        (my $name = $network->{name}) =~ s/^\w+:/nat_domain:/;
7919
443
1020
        my $domain = new(
7920            'nat_domain',
7921            name       => $name,
7922            networks   => [],
7923            routers    => [],
7924            nat_set    => {},
7925            );
7926
443
483
        push @natdomains, $domain;
7927
443
619
        set_natdomain($network, $domain, 0);
7928    }
7929
7930    # Distribute NAT tags to NAT domains.
7931
332
392
    for my $domain (@natdomains) {
7932
443
443
348
736
        for my $router (@{ $domain->{routers} }) {
7933
201
279
            my $nat_tags = $router->{nat_tags}->{$domain};
7934#            debug "$domain->{name} $router->{name}: ", join(',', @$nat_tags);
7935
7936            # Multiple tags are bound to interface.
7937            # If some network has multiple matching NAT tags,
7938            # the resulting NAT mapping would be ambiguous.
7939
201
299
            if (@$nat_tags >= 2) {
7940              NAT_TAG:
7941
3
3
                for my $nat_tag (@$nat_tags) {
7942
5
9
                    my $aref = $nat_tags2multi{$nat_tag} or next;
7943
5
6
                    for my $href (@$aref) {
7944
5
10
5
27
                        my @tags = grep { $href->{$_} && $_ } @$nat_tags;
7945
5
14
                        @tags >= 2 or next;
7946
1
2
                        my $tags = join(',', @tags);
7947
1
1
                        my $nat_net = $href->{$tags[0]};
7948
1
5
                        err_msg("Must not bind multiple NAT tags",
7949                                " '$tags' of $nat_net->{name}",
7950                                " at $router->{name}");
7951
7952                        # Show only first error. Otherwise we
7953                        # would show the same error multiple
7954                        # times.
7955
1
2
                        last NAT_TAG;
7956                    }
7957                }
7958            }
7959
201
300
            for my $nat_tag (@$nat_tags) {
7960
109
181
                if ($nat_definitions{$nat_tag}) {
7961
108
195
                    distribute_nat($domain, $nat_tag, \%nat_tags2multi,
7962                                   $router);
7963
108
304
                    $nat_definitions{$nat_tag} = 'used';
7964                }
7965                else {
7966
1
4
                    warn_msg("Ignoring useless nat:$nat_tag",
7967                             " bound at $router->{name}");
7968                }
7969            }
7970        }
7971    }
7972
7973    # Check compatibility of host/interface and network NAT.
7974    # A NAT definition for a single host/interface is only allowed,
7975    # if the network has a dynamic NAT definition.
7976
332
377
    for my $network (@networks) {
7977
1165
1165
1165
859
1174
1315
        for my $obj (@{ $network->{hosts} }, @{ $network->{interfaces} }) {
7978
1810
3414
            if ($obj->{nat}) {
7979
5
5
6
10
                for my $nat_tag (keys %{ $obj->{nat} }) {
7980
5
5
                    my $nat_network;
7981
5
23
                    if (    $nat_network = $network->{nat}->{$nat_tag}
7982                        and $nat_network->{dynamic})
7983                    {
7984
5
8
                        my $obj_ip = $obj->{nat}->{$nat_tag};
7985
5
5
5
9
                        my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
7986
5
9
                        if (not(match_ip($obj_ip, $ip, $mask))) {
7987
0
0
                            err_msg "nat:$nat_tag: $obj->{name}'s IP ",
7988                              "doesn't match $network->{name}'s IP/mask";
7989                        }
7990                    }
7991                    else {
7992
0
0
                        err_msg "nat:$nat_tag not allowed for ",
7993                          "$obj->{name} because $network->{name} ",
7994                          "doesn't have dynamic NAT definition";
7995                    }
7996                }
7997            }
7998        }
7999    }
8000
8001
332
587
    for my $name (keys %nat_definitions) {
8002
97
225
        $nat_definitions{$name} eq 'used' or
8003            warn_msg("nat:$name is defined, but not bound to any interface");
8004    }
8005
8006    # Find interfaces with dynamic NAT which is applied at the same device.
8007    # This is incomatible with device with "need_protect".
8008
332
393
    for my $network (@networks) {
8009
1165
1958
        my $nat = $network->{nat} or next;
8010
109
156
        for my $nat_tag (keys %$nat) {
8011
128
129
            my $nat_info = $nat->{$nat_tag};
8012
128
221
            $nat_info->{dynamic} or next;
8013
74
74
60
88
            for my $interface (@{ $network->{interfaces} }) {
8014
89
75
                my $intf_nat = $interface->{nat};
8015
8016                # Interface has static translation,
8017
89
171
                next if $intf_nat && $intf_nat->{$nat_tag};
8018
8019
86
72
                my $router = $interface->{router};
8020
86
237
                next if !$router->{need_protect};
8021
0
0
0
0
                for my $bind_intf (@{ $router->{interfaces} }) {
8022
0
0
                    my $bind = $bind_intf->{bind_nat} or next;
8023
0
0
0
0
                    grep { $_ eq $nat_tag } @$bind or next;
8024
0
0
                    err_msg("Must not apply dynamic NAT to $interface->{name}",
8025                            " at $bind_intf->{name} of same device.\n",
8026                            " This isn't supported for model",
8027                            " $router->{model}->{name}.");
8028                }
8029            }
8030        }
8031    }
8032
332
505
    invert_nat_set();
8033
332
543
    return;
8034}
8035
8036sub invert_nat_set {
8037
8038    # Find NAT partitions.
8039    # NAT partitions arise, if parts of the topology are strictly
8040    # separated by crypto interfaces.
8041
332
0
298
    my %partitions;
8042    my $mark_nat_partition;
8043    $mark_nat_partition = sub {
8044
679
618
        my ($domain, $mark) = @_;
8045
679
1406
        return if $partitions{$domain};
8046#        debug "$mark $domain->{name}";
8047
443
649
        $partitions{$domain} = $mark;
8048
443
443
368
875
        for my $router (@{ $domain->{routers} }) {
8049
201
201
155
220
            for my $out_domain (@{ $router->{nat_domains} }) {
8050
437
1008
                next if $out_domain eq $domain;
8051
236
428
                $mark_nat_partition->($out_domain, $mark);
8052            }
8053        }
8054
332
1117
    };
8055
332
347
    my $mark = 0;
8056
332
361
    for my $domain (@natdomains) {
8057
443
362
        $mark++;
8058
443
575
        $mark_nat_partition->($domain, $mark);
8059    }
8060
8061    # Collect NAT tags used in each partition.
8062
332
294
    my %partition2tags;
8063
332
359
    for my $domain (@natdomains) {
8064
443
574
        my $mark = $partitions{$domain};
8065
443
443
345
554
        for my $network (@{ $domain->{networks} }) {
8066
1112
2119
            my $href = $network->{nat} or next;
8067
109
165
            for my $nat_tag (keys %$href) {
8068
128
340
                $partition2tags{$mark}->{$nat_tag} = 1;
8069            }
8070        }
8071    }
8072
8073    # Invert {nat_set} to {no_nat_set}
8074
332
373
    for my $domain (@natdomains) {
8075
443
537
        my $nat_set = delete $domain->{nat_set};
8076
443
601
        my $mark = $partitions{$domain};
8077
443
1221
        my $all_nat_set = $partition2tags{$mark} ||= {};
8078#        debug "$mark $domain->{name} all: ", join(',', keys %$all_nat_set);
8079
443
774
        my $no_nat_set = { %$all_nat_set };
8080
443
443
554
474
        delete @{$no_nat_set}{keys %$nat_set};
8081
443
1109
        $domain->{no_nat_set} = $no_nat_set;
8082#        debug "$mark $domain->{name} no: ", join(',', keys %$no_nat_set);
8083    }
8084
8085    # Distribute {no_nat_set} to interfaces.
8086    # no_nat_set is needed at logical and hardware interfaces of
8087    # managed routers. Set it also for semi_managed routers to
8088    # calculate {up} relation between subnets.
8089
332
409
    for my $domain (@natdomains) {
8090
443
430
        my $no_nat_set = $domain->{no_nat_set};
8091
443
443
337
533
        for my $network (@{ $domain->{networks} }) {
8092
1112
1112
828
1240
            for my $interface (@{ $network->{interfaces} }) {
8093
1630
1372
                my $router = $interface->{router};
8094
1630
3746
                ($router->{managed} || $router->{semi_managed}) or next;
8095
8096#               debug("$domain->{name}: NAT $interface->{name}");
8097
1158
1303
                $interface->{no_nat_set} = $no_nat_set;
8098
1158
3266
                $interface->{hardware}->{no_nat_set} = $no_nat_set
8099                    if $router->{managed} || $router->{routing_only};
8100            }
8101        }
8102    }
8103
332
644
    return();
8104}
8105
8106# Real interface of crypto tunnel has got {no_nat_set} of that NAT domain,
8107# where encrypted traffic passes. But real interface gets ACL that filter
8108# both encrypted and unencrypted traffic. Hence no_nat_set must be extended by
8109# no_nat_set of some corresponding tunnel interface.
8110sub adjust_crypto_nat {
8111
332
0
296
    my %seen;
8112
332
525
    for my $crypto (values %crypto) {
8113
21
21
18
29
        for my $tunnel (@{ $crypto->{tunnels} }) {
8114
25
40
            next if $tunnel->{disabled};
8115
25
25
21
31
            for my $tunnel_intf (@{ $tunnel->{interfaces} }) {
8116
50
43
                my $real_intf = $tunnel_intf->{real_interface};
8117
50
117
                next if $seen{$real_intf}++;
8118
43
79
                $real_intf->{router}->{managed} or next;
8119
21
23
                my $tunnel_set = $tunnel_intf->{no_nat_set};
8120
21
63
                keys %$tunnel_set or next;
8121
8122                # Copy hash, because it is shared with other interfaces.
8123
3
4
                my $real_set = $real_intf->{no_nat_set};
8124
3
4
                $real_set = $real_intf->{no_nat_set} = { %$real_set };
8125
3
3
                my $hardware = $real_intf->{hardware};
8126
3
7
                $hardware->{no_nat_set} = $real_set if ref $hardware;
8127
3
7
                for my $nat_tag (sort keys %$tunnel_set) {
8128#                   debug "Adjust NAT of $real_intf->{name}: $nat_tag";
8129
3
12
                    $real_set->{$nat_tag} = 1;
8130                }
8131            }
8132        }
8133    }
8134
332
392
    return;
8135}
8136
8137sub get_nat_network {
8138
6083
0
5084
    my ($network, $no_nat_set) = @_;
8139
6083
11050
    if (my $href = $network->{nat} and $no_nat_set) {
8140
582
920
        for my $tag (keys %$href) {
8141
622
1178
            next if $no_nat_set->{$tag};
8142
299
528
            return $href->{$tag};
8143        }
8144    }
8145
5784
6405
    return $network;
8146}
8147
8148####################################################################
8149# Find sub-networks
8150# Mark each network with the smallest network enclosing it.
8151####################################################################
8152
8153# All interfaces and hosts of a network must be located in that part
8154# of the network which doesn't overlap with some subnet.
8155sub check_subnets {
8156
516
0
451
    my ($network, $subnet)   = @_;
8157
516
1303
    return if $network->{is_aggregate} || $subnet->{is_aggregate};
8158
180
180
149
261
    my ($sub_ip,  $sub_mask) = @{$subnet}{qw(ip mask)};
8159    my $check = sub {
8160
150
157
        my ($ip1, $ip2, $object) = @_;
8161
150
180
        if (
8162            match_ip($ip1, $sub_ip, $sub_mask)
8163            || $ip2 && (match_ip($ip2, $sub_ip, $sub_mask)
8164                || ($ip1 <= $sub_ip && $sub_ip <= $ip2))
8165          )
8166        {
8167
8168            # NAT to an interface address (masquerading) is allowed.
8169
0
0
            if (    (my $nat_tags = $object->{bind_nat})
8170                and (my ($nat_tag2) = ($subnet->{name} =~ /^nat:(.*)\(/)))
8171            {
8172
0
0
0
0
                if (    grep { $_ eq $nat_tag2 } @$nat_tags
8173                    and $object->{ip} == $subnet->{ip}
8174                    and $subnet->{mask} == 0xffffffff)
8175                {
8176
0
0
                    return;
8177                }
8178            }
8179
0
0
            warn_msg("$object->{name}'s IP overlaps with subnet",
8180                     " $subnet->{name}");
8181        }
8182
180
588
    };
8183
180
180
166
241
    for my $interface (@{ $network->{interfaces} }) {
8184
350
326
        my $ip = $interface->{ip};
8185
350
889
        next if $ip =~ /^(?:unnumbered|negotiated|tunnel|short|bridged)$/;
8186
145
185
        $check->($ip, undef, $interface);
8187    }
8188
180
180
179
248
    for my $host (@{ $network->{hosts} }) {
8189
5
15
        if (my $ip = $host->{ip}) {
8190
5
7
            $check->($ip, undef, $host);
8191        }
8192        elsif (my $range = $host->{range}) {
8193
0
0
            $check->($range->[0], $range->[1], $host);
8194        }
8195    }
8196
180
836
    return;
8197}
8198
8199# Dynamic NAT to loopback interface is OK,
8200# if NAT is applied at device of loopback interface.
8201sub nat_to_loopback_ok {
8202
3
0
3
    my ($loopback_network, $nat_network) = @_;
8203
8204
3
4
    my $nat_tag1      = $nat_network->{dynamic};
8205
3
4
    my $device_count  = 0;
8206
3
3
    my $all_device_ok = 0;
8207
8208    # In case of virtual loopback, the loopback network
8209    # is attached to two or more routers.
8210    # Loop over these devices.
8211
3
3
4
4
    for my $loop_intf (@{ $loopback_network->{interfaces} }) {
8212
5
5
        $device_count++;
8213
5
4
        my $this_device_ok = 0;
8214
8215        # Check all interfaces of attached device.
8216
5
5
4
9
        for my $all_intf (@{ $loop_intf->{router}->{interfaces} }) {
8217
5
9
            if (my $nat_tags = $all_intf->{bind_nat}) {
8218
5
5
6
11
                if (grep { $_ eq $nat_tag1 } @$nat_tags) {
8219
5
4
                    $this_device_ok = 1;
8220
5
6
                    last;
8221                }
8222            }
8223        }
8224
5
8
        $all_device_ok += $this_device_ok;
8225    }
8226
3
8
    return ($all_device_ok == $device_count);
8227}
8228
8229
1272
0
2008
sub numerically { return $a <=> $b }
8230
1812
0
2947
sub by_name     { return $a->{name} cmp $b->{name} }
8231
8232sub link_reroute_permit;
8233
8234# Find subnet relation between networks inside a zone.
8235# - $subnet->{up} = $bignet;
8236sub find_subnets_in_zone {
8237
332
0
457
    progress('Finding subnets in zone');
8238
332
350
    for my $zone (@zones) {
8239
8240        # Check NAT inside zone.
8241        # Find networks of zone which use a NATed address inside the zone.
8242        # - Use this NATed address in subnet checks.
8243        # - If a subnet relation exists, then this NAT must be unique inside
8244        #   the zone.
8245
8246
882
953
        my $first_intf = $zone->{interfaces}->[0];
8247
882
706
        my %seen;
8248
8249        # Collect NAT tags, that are defined and applied inside the zone.
8250        my %net2zone_nat_tags;
8251
8252        # Handle different no_nat_sets visible at border of zone.
8253        # For a zone without NAT, this loop is executed only once.
8254
882
882
672
1032
        for my $interface (@{ $zone->{interfaces} }) {
8255
1158
1036
            my $no_nat_set = $interface->{no_nat_set};
8256#            debug $interface->{name};
8257
1158
2784
            next if $seen{$no_nat_set}++;
8258
8259            # Add networks of zone to %mask_ip_hash.
8260            # Use NAT IP/mask.
8261
865
635
            my %mask_ip_hash;
8262
8263
865
865
865
642
892
1088
            for my $network (@{ $zone->{networks} },
8264                             values %{ $zone->{ipmask2aggregate} })
8265            {
8266
1107
2520
                next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/;
8267
8268
8269
1107
915
                my $nat_network = $network;
8270
1107
1635
                if (my $href = $network->{nat}) {
8271
113
182
                    for my $tag (keys %$href) {
8272
129
293
                        next if $no_nat_set->{$tag};
8273
16
16
15
49
                        push @{ $net2zone_nat_tags{$network} }, $tag;
8274
16
23
                        $nat_network = $href->{$tag};
8275
16
17
                        last;
8276                    }
8277                }
8278
8279
1107
1586
                if ($nat_network->{hidden}) {
8280
6
16
                    my $other = $network->{up} or next;
8281
1
2
                    next if get_nat_network($other, $no_nat_set)->{hidden};
8282
1
9
                    err_msg("Ambiguous subnet relation from NAT.\n",
8283                            " $network->{name} is subnet of\n",
8284                            " - $other->{name} at",
8285                            " $first_intf->{name}\n",
8286                            " - but it is hidden $nat_network->{name} at",
8287                            " $interface->{name}");
8288
1
3
                    next;
8289                }
8290
1101
1101
842
1639
                my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
8291
8292                # Found two different networks with identical IP/mask.
8293
1101
2297
                if (my $other_net = $mask_ip_hash{$mask}->{$ip}) {
8294
1
2
                    my $name1 = $network->{name};
8295
1
2
                    my $name2 = $other_net->{name};
8296
1
5
                    err_msg("$name1 and $name2 have identical IP/mask",
8297                            " at $interface->{name}");
8298                }
8299                else {
8300
8301                    # Store original network under NAT IP/mask.
8302
1100
2515
                    $mask_ip_hash{$mask}->{$ip} = $network;
8303                }
8304            }
8305
8306            # Compare networks of zone.
8307            # Go from smaller to larger networks.
8308
865
2215
            my @mask_list = reverse sort numerically keys %mask_ip_hash;
8309
865
1622
            while (my $mask = shift @mask_list) {
8310
8311                # No supernets available
8312
942
2916
                last if not @mask_list;
8313
8314
130
140
                my $ip_hash = $mask_ip_hash{$mask};
8315              SUBNET:
8316
130
320
                for my $ip (sort numerically keys %$ip_hash) {
8317
8318
160
161
                    my $subnet = $ip_hash->{$ip};
8319
8320                    # Find networks which include current subnet.
8321                    # @mask_list holds masks of potential supernets.
8322
160
175
                    for my $m (@mask_list) {
8323
8324
181
209
                        my $i = $ip & $m;
8325
181
420
                        my $bignet = $mask_ip_hash{$m}->{$i} or next;
8326
8327                        # Collect subnet relation for first no_nat_set.
8328
111
227
                        if ($interface eq $first_intf) {
8329
105
128
                            $subnet->{up} = $bignet;
8330#                           debug "$subnet->{name} -up-> $bignet->{name}";
8331
8332
105
235
                            push(
8333
17
36
                                @{ $bignet->{networks} },
8334                                $subnet->{is_aggregate}
8335
105
90
                                ? @{ $subnet->{networks} || [] }
8336                                : ($subnet)
8337                                );
8338
8339
105
168
                            check_subnets($bignet, $subnet);
8340                        }
8341
8342                        # Check for ambiguous subnet relation with
8343                        # other no_nat_sets.
8344
6
10
                        else {if (my $other = $subnet->{up}) {
8345
5
12
                                if ($other ne $bignet) {
8346
1
8
                                    err_msg(
8347                                        "Ambiguous subnet relation from NAT.\n",
8348                                        " $subnet->{name} is subnet of\n",
8349                                        " - $other->{name} at",
8350                                        " $first_intf->{name}\n",
8351                                        " - $bignet->{name} at",
8352                                        " $interface->{name}");
8353                                }
8354                            }
8355                            else {
8356
1
7
                                err_msg(
8357                                    "Ambiguous subnet relation from NAT.\n",
8358                                    " $subnet->{name} is subnet of\n",
8359                                    " - $bignet->{name} at",
8360                                    " $interface->{name}\n",
8361                                    " - but has no subnet relation at",
8362                                    " $first_intf->{name}");
8363                            }
8364                        }
8365
8366                        # We only need to find the smallest enclosing
8367                        # network.
8368
111
482
                        next SUBNET;                    
8369                    }
8370
49
174
                    if ($interface ne $first_intf) {
8371
3
6
                        if (my $other = $subnet->{up}) {
8372
3
16
                            err_msg("Ambiguous subnet relation from NAT.\n",
8373                                    " $subnet->{name} is subnet of\n",
8374                                    " - $other->{name} at",
8375                                    " $first_intf->{name}\n",
8376                                    " - but has no subnet relation at",
8377                                    " $interface->{name}");
8378                        }
8379                    }
8380                }
8381            }
8382        }
8383
8384        # For each subnet N find the largest non-aggregate network
8385        # which encloses N. If one exists, store it in %max_up_net.
8386        # This is used to exclude subnets from $zone->{networks} below.
8387        # It is also used to derive attribute {max_routing_net}.
8388
882
812
        my %max_up_net;
8389        my $set_max_net;
8390        $set_max_net = sub {
8391
2254
2511
            my ($network) = @_;
8392
2254
4032
            return if not $network;
8393
1182
2152
            if (my $max_net = $max_up_net{$network}) {
8394
4
6
                return $max_net;
8395            }
8396
1178
3020
            if (my $max_net = $set_max_net->($network->{up})) {
8397
66
113
                if (!$network->{is_aggregate}) {
8398
56
110
                    $max_up_net{$network} = $max_net;
8399
8400#                    debug("$network->{name} max_up $max_net->{name}");
8401                }
8402
66
130
                return $max_net;
8403            }
8404
1112
2009
            if ($network->{is_aggregate}) {
8405
40
74
                return;
8406            }
8407
1072
1829
            return $network;
8408
882
2493
        };
8409
882
882
758
1912
        $set_max_net->($_) for @{ $zone->{networks} };
8410
8411        # For each subnet N find the largest non-aggregate network
8412        # which encloses N and which has the same NAT settings as N.
8413        # If one exists, store it in {max_routing_net}. This is used
8414        # for generating static routes.
8415
882
882
771
1165
        for my $network (@{ $zone->{networks} }) {
8416
1076
2540
            my $max = $max_up_net{$network} or next;
8417#            debug "Check $network->{name} $max->{name}";
8418
8419            my $get_zone_nat = sub {
8420
130
119
                my ($network) = @_;
8421
130
337
                my $nat = $network->{nat} || {};
8422
8423                # Special case:
8424                # NAT is applied to $network inside the zone.
8425                # Ignore NAT tag when comparing with NAT of $up.
8426
130
242
                if (my $aref = $net2zone_nat_tags{$network}) {
8427
8
18
                    $nat = { %$nat };
8428
8
12
                    for my $nat_tag (@$aref) {
8429
8
17
                        delete $nat->{$nat_tag};
8430                    }
8431                }
8432
130
162
                return $nat;
8433
56
169
            };
8434
56
81
            my $nat = $get_zone_nat->($network);
8435
56
52
            my $max_routing;
8436
56
61
            my $up = $network->{up};
8437          UP:
8438
56
93
            while ($up) {
8439
8440                # Check if NAT settings are identical.
8441
74
85
                my $up_nat = $get_zone_nat->($up);
8442
74
161
                keys %$nat == keys %$up_nat or last UP;
8443
67
124
                for my $tag (keys %$nat) {
8444
3
6
                    my $up_nat_info = $up_nat->{$tag} or last UP;
8445
3
3
                    my $nat_info = $nat->{$tag};
8446
3
5
                    if ($nat_info->{hidden}) {
8447
0
0
                        $up_nat_info->{hidden} or last UP;
8448                    }
8449                    else {
8450
8451                        # Check if subnet relation is maintained
8452                        # for NAT addresses.
8453
3
5
                        $up_nat_info->{hidden} and last UP;
8454
3
3
2
4
                        my($ip, $mask) = @{$nat_info}{qw(ip mask)};
8455
3
7
                        match_ip($up_nat_info->{ip}, $ip, $mask) or last UP;
8456
1
4
                        $up_nat_info->{mask} >= $mask or last UP;
8457                    }
8458                }
8459
65
118
                if (!$up->{is_aggregate}) {
8460
50
53
                    $max_routing = $up;
8461                }
8462
65
135
                $up = $up->{up};
8463            }
8464
56
109
            if ($max_routing) {
8465
49
202
                $network->{max_routing_net} = $max_routing;
8466#                debug "Found $max_routing->{name}";
8467            }
8468        }
8469
8470        # Remove subnets of non-aggregate networks.
8471
1076
2438
        $zone->{networks} =
8472
882
882
800
1039
            [ grep { !$max_up_net{$_} } @{ $zone->{networks} } ];
8473
8474        # Propagate managed hosts to aggregates.
8475
882
882
953
2524
        for my $aggregate (values %{ $zone->{ipmask2aggregate} }) {
8476
53
105
            add_managed_hosts_to_aggregate($aggregate);
8477        }
8478    }
8479
8480    # It is valid to have an aggregate in a zone which has no matching
8481    # networks. This can be useful to add optimization rules at an
8482    # intermediate device.
8483
8484    # Change NAT at interface after above checks.
8485
332
517
    adjust_crypto_nat();
8486
8487    # Call late after $zone->{networks} has been set up.
8488
332
449
    link_reroute_permit();
8489
332
429
    check_managed_local();
8490
332
278
    return;
8491}
8492
8493# Find subnet relation inside a NAT domain.
8494# - $subnet->{is_in}->{$no_nat_set} = $bignet;
8495# - $net1->{is_identical}->{$no_nat_set} = $net2
8496#
8497# Mark networks, having subnet in other zone: $bignet->{has_other_subnet}
8498# If set, this prevents secondary optimization.
8499sub find_subnets_in_nat_domain {
8500
326
0
311
    my $count = @natdomains;
8501
326
761
    progress("Finding subnets in $count NAT domains");
8502
326
310
    my %seen;
8503
8504
326
375
    for my $domain (@natdomains) {
8505
437
438
        my $no_nat_set = $domain->{no_nat_set};
8506
8507#        debug("$domain->{name} ", join ',', sort keys %$no_nat_set);
8508
437
375
        my %mask_ip_hash;
8509        my %identical;
8510
437
442
        for my $network (@networks) {
8511
1768
3520
            next if $network->{ip} =~ /^(?:unnumbered|tunnel)$/;
8512
1698
1940
            my $nat_network = get_nat_network($network, $no_nat_set);
8513
1698
2460
            next if $nat_network->{hidden};
8514
1663
1663
1279
2095
            my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
8515
8516            # Found two different networks with identical IP/mask.
8517            # in current NAT domain.
8518
1663
2992
            if (my $old_net = $mask_ip_hash{$mask}->{$ip}) {
8519
57
71
                my $nat_old_net = get_nat_network($old_net, $no_nat_set);
8520
57
59
                my $error;
8521
57
238
                if ($old_net->{is_aggregate} || $network->{is_aggregate}) {
8522
41
92
                    if ($old_net->{zone} eq $network->{zone}) {
8523
0
0
                        $error = 1;
8524                    }
8525                    else {
8526
41
111
                        if (!$old_net->{is_aggregate}) {
8527
8528                            # This network has aggregate (with
8529                            # subnets) in other zone. Hence this
8530                            # network must not be used in secondary
8531                            # optimization.
8532
0
0
                            $old_net->{has_other_subnet} = 1;
8533                        }
8534                        elsif (!$network->{is_aggregate}) {
8535
0
0
                            $network->{has_other_subnet} = 1;
8536                        }
8537                    }
8538                }
8539                elsif ($nat_old_net->{dynamic} and $nat_network->{dynamic}) {
8540
8541                    # Dynamic NAT of different networks
8542                    # to a single new IP/mask is OK.
8543                }
8544                elsif ($old_net->{loopback} and $nat_network->{dynamic}) {
8545
3
7
                    nat_to_loopback_ok($old_net, $nat_network) or $error = 1;
8546                }
8547                elsif ($nat_old_net->{dynamic} and $network->{loopback}) {
8548
0
0
                    nat_to_loopback_ok($network, $nat_old_net) or $error = 1;
8549                }
8550                elsif (($network->{bridged} || 0) eq ($old_net->{bridged} || 1))
8551                {
8552
8553                    # Parts of bridged network have identical IP by design.
8554                }
8555                else {
8556
0
0
                    $error = 1;
8557                }
8558
57
94
                if ($error) {
8559
0
0
                    my $name1 = $nat_network->{name};
8560
0
0
                    my $name2 = $nat_old_net->{name};
8561
0
0
                    err_msg("$name1 and $name2 have identical IP/mask\n",
8562                            " in $domain->{name}");
8563                }
8564                else {
8565
8566                    # Remember identical networks.
8567
57
202
                    $identical{$old_net} ||= [$old_net];
8568
57
57
53
156
                    push @{ $identical{$old_net} }, $network;
8569                }
8570            }
8571            else {
8572
8573                # Store original network under NAT IP/mask.
8574
1606
2967
                $mask_ip_hash{$mask}->{$ip} = $network;
8575            }
8576        }
8577
8578        # Link identical networks to one representative one.
8579
437
780
        for my $networks (values %identical) {
8580
41
127
            $_->{is_supernet} = 1 for @$networks;
8581
41
59
            my $one_net = shift(@$networks);
8582
41
50
            for my $network (@$networks) {
8583
57
171
                $network->{is_identical}->{$no_nat_set} = $one_net;
8584#               debug("Identical: $network->{name}: $one_net->{name}");
8585            }
8586        }
8587
8588        # Go from smaller to larger networks.
8589
437
1163
        my @mask_list = reverse sort numerically keys %mask_ip_hash;
8590
437
1230
        while (my $mask = shift @mask_list) {
8591
8592            # No supernets available
8593
713
1931
            last if not @mask_list;
8594
8595
373
380
            my $ip_hash = $mask_ip_hash{$mask};
8596
373
1261
            for my $ip (sort numerically keys %$ip_hash) {
8597
8598                # It is sufficient to set subset relation for only one
8599                # network out of multiple identical networks.
8600                # In all contexts where {is_in} is used,
8601                # we apply {is_identical} to the network before.
8602
703
654
                my $subnet = $ip_hash->{$ip};
8603
8604                # Find networks which include current subnet.
8605                # @mask_list holds masks of potential supernets.
8606
703
666
                for my $m (@mask_list) {
8607
905
820
                    my $i = $ip & $m;
8608
905
2071
                    my $bignet = $mask_ip_hash{$m}->{$i} or next;
8609
527
608
                    my $nat_subnet = get_nat_network($subnet, $no_nat_set);
8610
527
623
                    my $nat_bignet = get_nat_network($bignet, $no_nat_set);
8611
8612                    # Mark subnet relation.
8613                    # This may differ for different NAT domains.
8614
527
950
                    $subnet->{is_in}->{$no_nat_set} = $bignet;
8615#                        debug "$subnet->{name} -is_in-> $bignet->{name}";
8616
8617
527
1009
                    if ($bignet->{zone} eq $subnet->{zone}) {
8618
222
356
                        if ($subnet->{has_other_subnet}) {
8619#                                debug "has other1: $bignet->{name}";
8620
6
9
                            $bignet->{has_other_subnet} = 1;
8621                        }
8622                    }
8623                    else {
8624#                            debug "has other: $bignet->{name}";
8625
305
334
                        $bignet->{has_other_subnet} = 1;
8626                    }
8627
8628                    # Mark network having subnets.  Rules having
8629                    # src or dst with subnets are collected into
8630                    # $expanded_rules->{supernet}
8631
527
504
                    $bignet->{is_supernet} = 1;
8632
8633
527
1161
                    if ($seen{$nat_bignet}->{$nat_subnet}) {
8634
116
283
                        last;
8635                    }
8636
411
658
                    $seen{$nat_bignet}->{$nat_subnet} = 1;
8637
8638
411
643
                    if ($config{check_subnets}) {
8639
8640                        # Take original $bignet, because currently
8641                        # there's no method to specify a natted network
8642                        # as value of subnet_of.
8643
411
1362
                        if (
8644                            not(   $bignet->{is_aggregate}
8645                                   or $subnet->{is_aggregate}
8646                                   or $bignet->{has_subnets}
8647                                   or $nat_subnet->{subnet_of}
8648                                   and $nat_subnet->{subnet_of} eq $bignet
8649                                   or $nat_subnet->{is_layer3})
8650                            )
8651                        {
8652
8653                            # Prevent multiple error messages in
8654                            # different NAT domains.
8655
2
8
                            $nat_subnet->{subnet_of} ||= $bignet;
8656
8657
2
14
                            my $msg =
8658                                "$nat_subnet->{name} is subnet of"
8659                                . " $nat_bignet->{name}\n"
8660                                . " in $domain->{name}.\n"
8661                                . " If desired, either declare attribute"
8662                                . " 'subnet_of' or attribute 'has_subnets'";
8663
8664
2
6
                            if ($config{check_subnets} eq 'warn') {
8665
2
4
                                warn_msg($msg);
8666                            }
8667                            else {
8668
0
0
                                err_msg($msg);
8669                            }
8670                        }
8671                    }
8672
8673
411
491
                    check_subnets($nat_bignet, $nat_subnet);
8674
411
1316
                    last;
8675                }
8676            }
8677        }
8678    }
8679
8680    # Secondary optimization substitutes a host or interface by its
8681    # largest valid supernet inside the same security zone. This
8682    # supernet has already been calculated and stored in
8683    # {max_routing_net}. But {max_routing_net} can't be used if it has
8684    # a subnet in some other security zone. In this case we have to
8685    # search again for a supernet without attribute {has_other_subnet}.
8686    # The result is stored in {max_secondary_net}.
8687
326
430
    for my $network (@networks) {
8688
1239
2114
        my $max = $network->{max_routing_net} or next;
8689
49
92
        if(!$max->{has_other_subnet}) {
8690
22
37
            $network->{max_secondary_net} = $max;
8691
22
26
            next;
8692        }
8693
27
28
        my $max_secondary;
8694
27
30
        my $up = $network->{up};
8695
27
43
        while ($up) {
8696
29
45
            if ($up->{has_other_subnet}) {
8697
27
20
                last;
8698            }
8699            else {
8700
2
4
                if (!$up->{is_aggregate}) {
8701
1
1
                    $max_secondary = $up;
8702                }
8703
2
3
                $up = $up->{up};
8704            }
8705        }
8706
27
51
        $network->{max_secondary_net} = $max_secondary if $max_secondary;
8707    }
8708
326
490
    return;
8709}
8710
8711#############################################################################
8712# Purpose  : Moves attribute 'no_in_acl' from interfaces to hardware because
8713#            ACLs operate on hardware, not on logic. Marks hardware needing
8714#            outgoing ACLs.
8715# Comments : Not more than 1 'no_in_acl' interface/router allowed.
8716sub check_no_in_acl  {
8717
8718    # Process every managed router
8719
337
0
393
    for my $router (@managed_routers) {
8720
485
394
        my $counter = 0; # count 'no_in_acl' interfaces/router
8721
8722        # At interfaces with no_in_acl move attribute to hardware
8723
485
485
399
603
        for my $interface (@{ $router->{interfaces} }) {
8724
1112
1949
            if (delete $interface->{no_in_acl}) {
8725
7
13
                my $hardware = $interface->{hardware};
8726
7
13
                $hardware->{no_in_acl} = 1;
8727
8728                # Assure max number of main interfaces at no_in_acl-hardware =1
8729
7
25
                1 ==
8730                  grep(
8731
7
7
9
13
                    { not $_->{main_interface} } @{ $hardware->{interfaces} })
8732                  or err_msg
8733                  "Only one logical interface allowed at $hardware->{name}",
8734                  " because it has attribute 'no_in_acl'";
8735
7
7
                $counter++;
8736
8737                # Reference no_in_acl interface in router attribute
8738
7
12
                $router->{no_in_acl} = $interface;
8739            }
8740        }
8741
485
965
        next if not $counter;
8742
8743        # Assert maximum number of 'no_in_acl' interfaces per router
8744
7
15
        $counter == 1
8745          or err_msg "At most one interface of $router->{name}",
8746          " may use flag 'no_in_acl'";
8747
8748        # Assert router to support outgoing ACL
8749
7
17
        $router->{model}->{has_out_acl}
8750          or err_msg("$router->{name} doesn't support outgoing ACL");
8751
8752        # Assert router not to take part in crypto tunnels
8753
7
23
7
12
84
10
        if (grep { $_->{hub} or $_->{spoke} } @{ $router->{interfaces} }) {
8754
0
0
            err_msg "Don't use attribute 'no_in_acl' together",
8755              " with crypto tunnel at $router->{name}";
8756        }
8757
8758        # Mark other hardware with attribute 'need_out_acl'.
8759
7
7
10
11
        for my $hardware (@{ $router->{hardware} }) {
8760
22
48
            $hardware->{no_in_acl}
8761              or $hardware->{need_out_acl} = 1;
8762        }
8763    }
8764
337
319
    return;
8765}
8766
8767# If routers are connected by crosslink network then
8768# no filter is needed if both have equal strength.
8769# If routers have different strength,
8770# then only the weakest devices omit the filter.
8771my %crosslink_strength = (
8772    primary => 10,
8773    full => 10,
8774    standard => 9,
8775    secondary => 8,
8776    local => 7,
8777    local_secondary => 6,
8778    );
8779##############################################################################
8780    # Find clusters of routers connected directly or indirectly by
8781    # crosslink networks and having at least one device with
8782    # "need_protect".
8783sub cluster_crosslink_routers {
8784
337
0
345
    my ($crosslink_routers) = @_;
8785
337
287
    my %cluster;
8786    my %seen;
8787
0
0
    my $walk;
8788
8789    # add routers to cluster via depth first search
8790    $walk = sub {
8791
17
15
        my ($router) = @_;
8792
17
24
        $cluster{$router} = $router;
8793
17
25
        $seen{$router}    = $router;
8794
17
17
12
20
        for my $in_intf (@{ $router->{interfaces} }) {
8795
36
34
            my $network = $in_intf->{network};
8796
36
63
            next if not $network->{crosslink};
8797
18
24
            next if $network->{disabled};
8798
18
18
15
20
            for my $out_intf (@{ $network->{interfaces} }) {
8799
42
81
                next if $out_intf eq $in_intf;
8800
24
24
                my $router2 = $out_intf->{router};
8801
24
60
                next if $cluster{$router2};
8802
9
21
                $walk->($router2);
8803            }
8804        }
8805
337
1099
    };
8806
8807    # Process all need_protect crosslinked routers
8808
337
725
    for my $router (values %$crosslink_routers) {
8809
10
19
        next if $seen{$router};
8810
8811        # Fill router cluster
8812
8
9
        %cluster = ();
8813
8
12
        $walk->($router);
8814
8815        # Collect all interfaces belonging to need_protect routers of cluster...
8816
21
33
        my @crosslink_interfaces =
8817
10
15
          grep { !$_->{vip} }
8818
10
17
9
27
          map { @{ $_->{interfaces} } }
8819
8
27
          grep { $crosslink_routers->{$_} }          
8820          sort by_name values %cluster; # Sort to make output deterministic.
8821
8822        # ... add information to every cluster member
8823
8
20
9
47
        my %crosslink_intf_hash = map { $_ => $_ } @crosslink_interfaces;
8824
8
11
        for my $router2 (values %cluster) {
8825            # ... as list used in "protect own interfaces"
8826
17
20
            $router2->{crosslink_interfaces} = \@crosslink_interfaces;
8827            # ... as hash used in fast lookup in distribute_rule and "protect.."
8828
17
31
            $router2->{crosslink_intf_hash}  = \%crosslink_intf_hash;
8829        }
8830    }
8831
337
466
    return;
8832}
8833##############################################################################
8834# A crosslink network combines two or more routers to one virtual router.
8835# Purpose  : Assures proper usage of crosslink networks and applies the
8836#            crosslink attribute to the networks weakest interfaces (no
8837#            filtering needed at these interfaces).
8838# Comments : Function uses hardware attributes from sub check_no_in_acl.
8839sub check_crosslink  {
8840
337
0
290
    my %crosslink_routers; # Collect crosslinked routers with {need_protect}
8841
8842    # Process all crosslink networks
8843
337
528
    for my $network (values %networks) {
8844
1115
1888
        next if not $network->{crosslink};
8845
10
19
        next if $network->{disabled};
8846
8847        # Prepare tests.
8848
10
7
        my %strength2intf;# To identify interfaces with min router strength
8849
10
8
        my $out_acl_count = 0; # Assure out_ACL at all/none of the interfaces  
8850
10
10
        my @no_in_acl_intf; # Assure all no_in_acl IFs to border the same zone
8851
8852        # Process network interfaces to fill above variables.
8853
10
10
6
16
        for my $interface (@{ $network->{interfaces} }) {
8854
19
28
            next if $interface->{main_interface};
8855
18
18
            my $router = $interface->{router};
8856
18
17
            my $hardware = $interface->{hardware};
8857
8858            # Assure correct usage of crosslink network.
8859
18
25
            if (!$router->{managed}) {
8860
1
4
                err_msg("Crosslink $network->{name} must not be",
8861                        " connected to unmanged $router->{name}");
8862
1
2
                next;
8863            }
8864
17
18
17
17
44
20
            1 == grep({ !$_->{main_interface} } @{ $hardware->{interfaces} })
8865              or err_msg
8866              "Crosslink $network->{name} must be the only network\n",
8867              " connected to $hardware->{name} of $router->{name}";
8868
8869            # Fill variables.
8870
17
18
            my $managed = $router->{managed};            
8871
17
29
            my $strength = $crosslink_strength{$managed} or
8872                internal_err("Unexptected managed=$managed");            
8873
17
17
13
34
            push @{ $strength2intf{$strength} }, $interface;
8874
8875
17
29
            if ($router->{need_protect}) {
8876
10
18
                $crosslink_routers{$router} = $router;
8877            }
8878
8879
17
26
            if ($hardware->{need_out_acl}) {
8880
0
0
                $out_acl_count++;
8881            }
8882
8883
36
49
            push @no_in_acl_intf,
8884
17
17
12
18
              grep({ $_->{hardware}->{no_in_acl} } @{ $router->{interfaces} });
8885        }
8886
8887        # Apply attribute {crosslink} to the networks weakest interfaces.
8888
10
32
        if (my ($weakest) = sort numerically keys %strength2intf) {
8889
8
8
7
11
            for my $interface (@{ $strength2intf{$weakest} }) {
8890
13
21
                $interface->{hardware}->{crosslink} = 1;
8891            }
8892
8893            # Assure 'secondary' and 'local' are not mixed in crosslink network.
8894
8
25
            if ($weakest == $crosslink_strength{local} &&
8895                $strength2intf{$crosslink_strength{secondary}}) {
8896
1
4
                err_msg("Must not use 'managed=local' and 'managed=secondary'",
8897                        " together\n at crosslink $network->{name}");
8898            }
8899        }
8900
8901        # Assure proper usage of crosslink network.
8902
0
0
        not $out_acl_count
8903
10
23
          or $out_acl_count == @{ $network->{interfaces} }
8904          or err_msg "All interfaces must equally use or not use outgoing ACLs",
8905          " at crosslink $network->{name}";
8906
10
0
18
0
        equal(map { $_->{zone} } @no_in_acl_intf)
8907          or err_msg "All interfaces with attribute 'no_in_acl'",
8908          " at routers connected by\n crosslink $network->{name}",
8909          " must be border of the same security zone";
8910    }
8911
337
492
    return \%crosslink_routers;
8912}
8913
8914# Find cluster of zones connected by 'local' or 'local_secondary' routers.
8915# - Check consistency of attributes.
8916# - Set unique 'local_mark' for all zones belonging to one cluster
8917# - Set 'local_secondary_mark' for secondary optimization inside one cluster.
8918#   Two zones get the same mark if they are connected by local_secondary router.
8919sub check_managed_local {
8920
332
0
259
    my %seen;
8921
332
309
    my $cluster_counter = 1;
8922
332
357
    for my $router (@managed_routers) {
8923
485
1144
        $router->{managed} =~ /^local/ or next;
8924
27
60
        next if $seen{$router};
8925
8926        # Networks of current cluster matching {filter_only}.
8927
20
14
        my %matched;
8928
8929        my $walk;
8930        $walk = sub {
8931
27
29
            my ($router) = @_;
8932
27
28
            my $filter_only = $router->{filter_only};
8933
27
19
            my $k;
8934
27
45
            $seen{$router} = $router;
8935
27
27
22
33
            for my $in_intf (@{ $router->{interfaces} }) {
8936
54
48
                my $no_nat_set = $in_intf->{no_nat_set};
8937
54
44
                my $zone0 = $in_intf->{zone};
8938
54
42
                my $zone_cluster = $zone0->{zone_cluster};
8939
54
77
                for my $zone ($zone_cluster ? @$zone_cluster : ($zone0)) {
8940
54
79
                    next if $zone->{disabled};
8941
54
91
                    next if $zone->{local_mark};
8942
44
44
                    $zone->{local_mark} = $cluster_counter;
8943
8944                    # All networks in local zone must match {filter_only}.
8945
44
44
                  NETWORK:
8946
44
44
33
56
                    for my $network (@{ $zone->{networks} },
8947                                     values %{ $zone->{ipmask2aggregate} })
8948                    {
8949
46
46
31
58
                        my ($ip, $mask) = @{ address($network, $no_nat_set) };
8950
8951                        # Ignore aggregate 0/0 which is available in
8952                        # every zone.
8953
46
100
                        next if $mask == 0 && $network->{is_aggregate};
8954
45
51
                        for my $pair (@$filter_only) {
8955
50
56
                            my ($i, $m) = @$pair;
8956
50
103
                            if ($mask >= $m && match_ip($ip, $i, $m)) {
8957
42
98
                                $matched{"$i/$m"} = 1;
8958
42
90
                                next NETWORK;
8959                            }
8960                        }
8961
3
12
                        err_msg("$network->{name} doesn't match attribute",
8962                                " 'filter_only' of $router->{name}");
8963                    }
8964
44
44
38
57
                    for my $out_intf (@{ $zone->{interfaces} }) {
8965
66
207
                        next if $out_intf eq $in_intf;
8966
22
22
                        my $router2 = $out_intf->{router};
8967
22
38
                        my $managed = $router2->{managed} or next;
8968
22
62
                        next if $managed !~ /^local/;
8969
10
23
                        next if $seen{$router2};
8970
8971                        # All routers of a cluster must have same values in
8972                        # {filter_only}.
8973
7
7
17
26
                        $k ||= join(',', map({ join('/', @$_) }
8974                                             @$filter_only));
8975
8
7
22
15
                        my $k2 = join(',', map({ join('/', @$_) }
8976
7
11
                                               @{ $router2->{filter_only} }));
8977
7
18
                        $k2 eq $k or
8978                            err_msg("$router->{name} and $router2->{name}",
8979                                    " must have identical values in",
8980                                    " attribute 'filter_only'");
8981
8982
7
23
                        $walk->($router2);
8983                    }
8984                }
8985            }
8986
20
96
        };
8987
8988
20
32
        $walk->($router);
8989
20
15
        $cluster_counter++;
8990
8991
20
20
17
27
        for my $pair (@{ $router->{filter_only} }) {
8992
25
25
            my ($i, $m) = @$pair;
8993
25
82
            $matched{"$i/$m"} and next;
8994
1
2
            my $ip = print_ip($i);
8995
1
2
            my $prefix = mask2prefix($m);
8996
1
5
            warn_msg("Useless $ip/$prefix in attribute 'filter_only'",
8997                     " of $router->{name}");
8998        }
8999    }
9000
332
391
    return;
9001}
9002
9003# group of reroute_permit networks must be expanded late, after areas,
9004# aggregates and subnets have been set up. Otherwise automatic groups
9005# wouldn't work.
9006#
9007# Reroute permit is not allowed between different security zones.
9008sub link_reroute_permit {
9009
332
0
374
    for my $zone (@zones) {
9010
882
882
673
1057
        for my $interface (@{ $zone->{interfaces} }) {
9011
1158
2432
            my $group = $interface->{reroute_permit} or next;
9012
2
6
            $group =
9013              expand_group($group, "'reroute_permit' of $interface->{name}");
9014
2
3
            my @checked;
9015
2
2
            for my $obj (@$group) {
9016
2
3
                if (is_network($obj)) {
9017
2
2
                    my $net_zone = $obj->{zone};
9018
2
4
                    if (!zone_eq($net_zone, $zone)) {
9019
0
0
                        err_msg("Invalid reroute_permit for $obj->{name} ",
9020                                "at $interface->{name}:",
9021                                " different security zones");
9022                    }
9023                    else {
9024
2
4
                        push @checked, $obj;
9025                    }
9026                }
9027                else {
9028
0
0
                    err_msg("$obj->{name} not allowed in attribute",
9029                            " 'reroute_permit' of $interface->{name}");
9030                }
9031            }
9032
2
6
            $interface->{reroute_permit} = \@checked;
9033        }
9034    }  
9035
332
326
    return;  
9036}
9037
9038##############################################################################
9039# Purpose  :
9040sub add_managed_hosts_to_aggregate {
9041
160
0
140
    my ($aggregate) = @_;
9042
9043    # Collect managed hosts of sub-networks.
9044
160
160
    my $networks = $aggregate->{networks};
9045
160
225
    if (@$networks) {
9046
127
162
        for my $network (@$networks) {
9047
147
355
            my $managed_hosts = $network->{managed_hosts} or next;
9048
2
2
2
6
            push(@{ $aggregate->{managed_hosts} }, @$managed_hosts);
9049        }
9050    }
9051
9052    # Collect matching managed hosts of all networks of zone.
9053    # Ignore sub-networks of aggregate, because they would have been
9054    # found in $networks above.
9055    else {
9056
33
33
42
51
        my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9057
33
33
        my $zone = $aggregate->{zone};
9058
33
33
1069
48
        for my $network (@{ $zone->{networks} }) {
9059
30
76
            next if $network->{mask} > $mask ;
9060
10
29
            my $managed_hosts = $network->{managed_hosts} or next;
9061
1
2
3
4
            push(@{ $aggregate->{managed_hosts} },
9062
1
1
                 grep { match_ip($_->{ip}, $ip, $mask) } @$managed_hosts);
9063        }
9064    }
9065
160
249
    return;
9066}
9067
9068####################################################################
9069# Borders of security zones are
9070# a) interfaces of managed devices and
9071# b) interfaces of devices, which have at least one pathrestriction applied.
9072#
9073# For each security zone create a zone object.
9074# Link each interface at the border with the zone and vice versa.
9075# Additionally link each network and unmanaged router with the zone.
9076# Add a list of all its numbered networks to the zone.
9077####################################################################
9078
9079##############################################################################
9080# Purpose  : Link aggregate and zone via references in both objects, set
9081#            aggregate properties according to those of the linked zone.
9082#            Store aggregates in @networks (providing all srcs and dsts).
9083sub link_aggregate_to_zone {
9084
160
0
185
    my ($aggregate, $zone, $key) = @_;
9085
9086    # Link aggregate with zone.
9087
160
180
    $aggregate->{zone} = $zone;
9088
160
221
    $zone->{ipmask2aggregate}->{$key} = $aggregate;
9089
9090    # Take a new array for each aggregate, otherwise we would share
9091    # the same array between different aggregates.
9092
160
372
    $aggregate->{networks} ||= [];# Has to be initialized, even if it is empty
9093
9094    # Set aggregate properties
9095
160
256
    $zone->{is_tunnel} and $aggregate->{is_tunnel} = 1;
9096
160
242
    $zone->{has_id_hosts} and $aggregate->{has_id_hosts} = 1;
9097
9098
160
224
    if ($zone->{disabled}) {
9099
0
0
        $aggregate->{disabled} = 1;
9100    }
9101
9102    # Store aggregate reference in global network hash
9103    else {
9104
160
174
        push @networks, $aggregate; # @networks provides all srcs/dsts
9105    }
9106
160
222
    return;
9107}
9108
9109##############################################################################
9110# Update relations {networks}, {up} and {owner} for implicitly defined
9111# aggregates.
9112# Remember:
9113# {up} is relation inside set of all networks and aggregates.
9114# {networks} is attribute of aggregates and networks,
9115#            but value is list of networks.
9116sub link_implicit_aggregate_to_zone {
9117
107
0
120
    my ($aggregate, $zone, $key) = @_;
9118
107
226
    my ($ip, $mask) = split '/', $key;
9119
107
121
    my $ipmask2aggregate = $zone->{ipmask2aggregate};
9120
9121    # Collect all aggregates, networks and subnets of current zone.
9122    # Get aggregates in deterministic order.
9123
107
107
145
132
    my @objects = @{$ipmask2aggregate}{ sort keys %$ipmask2aggregate };
9124
107
95
    my $add_subnets;
9125    $add_subnets = sub {
9126
129
127
        my ($network) = @_;
9127
129
363
        my $subnets = $network->{networks} or return;
9128
3
1
        push @objects, @$subnets;
9129
3
9
        $add_subnets->($_) for @$subnets;
9130
107
298
    };
9131
107
107
93
156
    push @objects, @{ $zone->{networks} };
9132
107
107
89
218
    $add_subnets->($_) for @{ $zone->{networks} };
9133
9134    # Collect all objects being larger and smaller than new aggregate.
9135
107
144
128
287
    my @larger  = grep { $_->{mask} < $mask } @objects;
9136
107
144
102
233
    my @smaller = grep { $_->{mask} > $mask } @objects;
9137
9138    # Find subnets of new aggregate.
9139
107
124
    for my $obj (@smaller) {
9140
132
132
105
192
        my ($i, $m) = @{$obj}{qw(ip mask)};
9141
132
178
        match_ip($i, $ip, $mask) or next;
9142
9143        # Ignore sub-subnets, i.e. supernet is smaller than new aggregate.
9144
117
205
        if (my $up = $obj->{up}) {
9145
15
31
            next if $up->{mask} >= $mask;
9146        }
9147
105
114
        $obj->{up} = $aggregate;
9148#        debug "$obj->{name} -up1-> $aggregate->{name}";
9149
105
9
301
17
        push(@{ $aggregate->{networks} },
9150
105
92
             $obj->{is_aggregate} ? @{ $obj->{networks} } : $obj);
9151    }
9152
9153    # Find supernet of new aggregate.
9154    # Iterate from smaller to larger supernets.
9155    # Stop after smallest supernet has been found.
9156
107
3
190
5
    for my $obj (sort { $a->{mask} < $b->{mask} } @larger) {
9157
8
8
9
11
        my ($i, $m) = @{$obj}{qw(ip mask)};
9158
8
11
        match_ip($ip, $i, $m) or next;
9159
7
10
        $aggregate->{up} = $obj;
9160#        debug "$aggregate->{name} -up2-> $obj->{name}";
9161
7
8
        last;
9162    }
9163
9164    # Inherit owner from smallest supernet having owner or from zone.
9165
107
115
    my $up = $aggregate->{up};
9166
107
91
    my $owner;
9167
107
190
    while ($up) {
9168
7
12
        $owner = $up->{owner} and last;
9169
7
12
        $up = $up->{up};
9170    }
9171
107
302
    $owner ||= $zone->{owner};
9172
107
157
    $owner and $aggregate->{owner} = $owner;
9173
9174
107
139
    link_aggregate_to_zone($aggregate, $zone, $key);
9175
107
138
    add_managed_hosts_to_aggregate($aggregate);
9176
107
164
    return;
9177}
9178
9179##############################################################################
9180# Purpose  : Process all explicitly defined aggregates. Check proper usage of
9181#            aggregates. For every aggregate, link aggregate objects to all
9182#            zones inside the zone cluster containing the aggregates link
9183#            network and set aggregate and zone properties. Add aggregate
9184#            objects to global @networks array.
9185# Comments : Has to be called after zones have been set up. But before
9186#            find_subnets_in_zone calculates {up} and {networks} relation.
9187sub link_aggregates {
9188
9189
337
0
279
    my @aggregates_in_cluster; # Collect all aggregates inside clusters
9190
9191
9192
337
631
    for my $name (sort keys %aggregates) {
9193
52
70
        my $aggregate = $aggregates{$name};
9194
52
52
50
102
        my ($type, $name) = @{ delete($aggregate->{link}) };
9195
52
73
        my $err;
9196        my $router;
9197
9198        # Assure aggregates to be linked to networks only
9199
52
112
        if ($type ne 'network') {
9200
1
5
            err_msg("$aggregate->{name} must not be linked to $type:$name");
9201
1
1
            $aggregate->{disabled} = 1;
9202
1
3
            next;
9203        }
9204
9205        # Assure aggregate link to exist/disable aggregates without active links
9206
51
62
        my $network = $networks{$name};
9207
51
91
        if (not $network) {
9208
0
0
            err_msg("Referencing undefined $type:$name",
9209                    " from $aggregate->{name}");
9210
0
0
            $aggregate->{disabled} = 1;
9211
0
0
            next;
9212        }
9213
51
114
        if ($network->{disabled}) {
9214
1
2
            $aggregate->{disabled} = 1;
9215
1
2
            next;
9216        }
9217
9218        # Reference network link in security zone.
9219
50
52
        my $zone     = $network->{zone};
9220
50
60
        $zone->{link} = $network; # only used in cut-netspoc
9221
9222        # Assure aggregate and network private status to be equal
9223
50
147
        my $private1 = $aggregate->{private} || 'public';
9224
50
50
        my $private2 = $network->{private};
9225
50
142
        $private2 ||= 'public';
9226
50
84
        $private1 eq $private2
9227            or err_msg("$private1 $aggregate->{name} must not be linked",
9228                       " to $private2 $type:$name");
9229
9230        # Assure that no other aggregate with same IP and mask exists in cluster
9231
50
50
48
88
        my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9232
50
111
        my $key = "$ip/$mask";
9233
50
51
        my $cluster = $zone->{zone_cluster};
9234
50
97
        for my $zone2 ($cluster ? @$cluster : ($zone)) {
9235
55
157
            if (my $other = $zone2->{ipmask2aggregate}->{$key}) {
9236
1
5
                err_msg("Duplicate $other->{name} and $aggregate->{name}",
9237                        " in $zone->{name}");
9238            }
9239        }
9240
9241        # Collect aggregates inside clusters
9242
50
94
        if ($cluster) {
9243
4
5
            push(@aggregates_in_cluster, $aggregate);
9244        }
9245
9246        # Use aggregate with ip 0/0 to set attributes of all zones in cluster.
9247        #
9248        # Even NAT is moved to zone for aggregate 0/0 although we
9249        # retain NAT at other aggregates.
9250        # This is an optimization to prevent the creation of many aggregates 0/0
9251        # if only inheritance of NAT from area to network is needed.
9252
50
90
        if ($mask == 0) {
9253
29
38
            for my $attr (qw(has_unenforceable owner nat)) {
9254
87
173
                if (my $v = delete $aggregate->{$attr}) {
9255
16
31
                    for my $zone2 ($cluster ? @$cluster : ($zone)) {
9256
17
44
                        $zone2->{$attr} = $v;
9257                    }
9258                }
9259            }
9260        }
9261        # Link aggragate and zone (also setting zone{ipmask2aggregate}
9262
50
87
        link_aggregate_to_zone($aggregate, $zone, $key);
9263    }
9264
9265    # add aggregate to all zones in the zone cluster
9266
337
416
    for my $aggregate (@aggregates_in_cluster) {
9267
4
6
        duplicate_aggregate_to_cluster($aggregate);
9268    }
9269
337
305
    return;
9270}
9271##############################################################################
9272# Parameter: $aggregate object reference, $implicit flag
9273# Purpose  : Create an aggregate object for every zone inside the zones cluster
9274#            containing the aggregates link-network.
9275# Comments : From users point of view, an aggregate refers to networks of a zone
9276#            cluster. Internally, an aggregate object represents a set of
9277#            networks inside a zone. Therefeore, every zone inside a cluster
9278#            gets its own copy of the defined aggregate to collect the zones
9279#            networks matching the aggregates IP address.
9280# TDOD     : Aggregate may be a non aggregate network,
9281#            e.g. a network with ip/mask 0/0. ??
9282sub duplicate_aggregate_to_cluster {
9283
10
0
11
    my ($aggregate, $implicit) = @_;
9284
10
14
    my $cluster = $aggregate->{zone}->{zone_cluster};
9285
10
10
8
16
    my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9286
10
18
    my $key = "$ip/$mask";
9287
9288    # Process every zone of the zone cluster
9289
10
13
    for my $zone (@$cluster) {
9290
24
50
        next if $zone->{ipmask2aggregate}->{$key};
9291#        debug("Dupl. $aggregate->{name} to $zone->{name}");
9292
9293        # Create new aggregate object for every zone inside the cluster
9294
12
24
        my $aggregate2 = new(
9295            'Network',
9296            name         => $aggregate->{name},
9297            is_aggregate => 1,
9298            ip           => $aggregate->{ip},
9299            mask         => $aggregate->{mask},
9300            );
9301
9302        # Link new aggregate object and cluster
9303
12
16
        if ($implicit) {
9304
9
12
            link_implicit_aggregate_to_zone($aggregate2, $zone, $key);
9305        }
9306        else {
9307
3
4
            link_aggregate_to_zone($aggregate2, $zone, $key);
9308        }
9309    }
9310
10
15
    return;
9311}
9312
9313###############################################################################
9314# Find aggregate referenced from any:[..].
9315# Creates new anonymous aggregate if missing.
9316# If zone is part of a zone_cluster,
9317# return aggregates for each zone of the cluster.
9318sub get_any {
9319
184
0
188
    my ($zone, $ip, $mask) = @_;
9320
184
330
    my $key = "$ip/$mask";
9321
184
170
    my $cluster = $zone->{zone_cluster};
9322
184
330
    if (!$zone->{ipmask2aggregate}->{$key}) {
9323
9324        # Check, if there is a network with same IP as the requested
9325        # aggregate.  If found, don't create a new aggregate in zone,
9326        # but use the network instead. Otherwise {up} relation
9327        # wouldn't be well defined.
9328
99
127
108
149
417
210
        if (my @networks = grep({ $_->{mask} == $mask && $_->{ip} == $ip }
9329
108
83
                                map { @{ $_->{networks} } }
9330                                $cluster ? @$cluster : ($zone)))
9331        {
9332
1
3
            @networks > 1 and internal_err;
9333
1
2
            my ($network) = @networks;
9334
1
1
            my $zone2 = $network->{zone};
9335
9336            # Handle $network like an aggregate.
9337
1
2
            $zone2->{ipmask2aggregate}->{$key} = $network;
9338
9339            # Create aggregates in cluster, using the name of the network.
9340
1
2
            duplicate_aggregate_to_cluster($network, 1) if $cluster;
9341        }
9342        else {
9343
9344            # any:[network:x] => any:[ip=i.i.i.i/pp & network:x]
9345
98
135
            my $p_ip = print_ip($ip);
9346
98
136
            my $prefix = mask2prefix($mask);
9347
98
111
            my $name = $zone->{name};
9348
98
365
            $name =~ s/\[/[ip=$p_ip\/$prefix & / if $prefix != 0;
9349
98
153
            my $aggregate = new(
9350                'Network',
9351                name         => $name,
9352                is_aggregate => 1,
9353                ip           => $ip,
9354                mask         => $mask,
9355                );
9356
98
175
            if (my $private = $zone->{private}) {
9357
0
0
                $aggregate->{private} = $private;
9358            }
9359
98
150
            link_implicit_aggregate_to_zone($aggregate, $zone, $key);
9360
98
207
            duplicate_aggregate_to_cluster($aggregate, 1) if $cluster;
9361        };
9362    }
9363
184
239
    if ($cluster) {
9364
12
79
        return get_cluster_aggregates($zone, $ip, $mask);
9365    }
9366    else {
9367
172
529
        return $zone->{ipmask2aggregate}->{$key};
9368    }
9369}
9370
9371# Get set of aggregates of a zone cluster.
9372# Ignore zone having no aggregate from unnumbered network.
9373sub get_cluster_aggregates {
9374
12
0
15
    my ($zone, $ip, $mask) = @_;
9375
12
20
    my $key = "$ip/$mask";
9376    return
9377
12
32
12
8
108
17
        map { $_->{ipmask2aggregate}->{$key}||() } @{ $zone->{zone_cluster} };
9378}
9379
9380###############################################################################
9381# Purpose  : Collects all elements (networks, unmanaged routers, interfaces) of
9382#            a zone object and references the zone in its elements. Sets zone
9383#            property flags and private status.
9384# Comments : Unnumbered and tunnel networks are not referenced in zone objects,
9385#            as they are no valid src or dst.
9386sub set_zone1 {
9387
1148
0
1094
    my ($network, $zone, $in_interface) = @_;
9388
9389    # Return if network was processed already (= loop was found).
9390
1148
1749
    if ($network->{zone}) {
9391
36
61
        return;
9392    }
9393
9394    # Reference zone in network and vice versa...
9395
1112
1185
    $network->{zone} = $zone;
9396
1112
2646
    if (not($network->{ip} =~ /^(?:unnumbered|tunnel)$/)) {# no valid src/dst
9397
1076
1076
787
1492
        push @{ $zone->{networks} }, $network;
9398    }
9399#    debug("$network->{name} in $zone->{name}");
9400
9401    # Set zone property flags depending on network properties...
9402
1112
1904
    $network->{ip} eq 'tunnel' and $zone->{is_tunnel} = 1;
9403
1112
1578
    $network->{has_id_hosts} and $zone->{has_id_hosts} = 1;
9404
9405    # Check network 'private' status and zone 'private' status to be equal.
9406
1112
2796
    my $private1 = $network->{private} || 'public';
9407
1112
1546
    if ($zone->{private}) {
9408
230
196
        my $private2 = $zone->{private};
9409
230
432
        if ($private1 ne $private2) {
9410
1
1
            my $other = $zone->{networks}->[0];
9411
1
8
            err_msg("All networks of $zone->{name} must have",
9412                    " identical 'private' status\n",
9413                    " - $other->{name}: $private2\n",
9414                    " - $network->{name}: $private1");
9415        }
9416    }
9417
9418    # Set zone private status (attribute will be removed if value is 'public')
9419
1112
1122
    $zone->{private} = $private1;# TODO: is set in every iteration. else clause?
9420
9421    # Proceed with adjacent elements...
9422
1112
1112
836
1391
    for my $interface (@{ $network->{interfaces} }) {        
9423
1630
3067
        next if $interface eq $in_interface; # Ignore Interface we came from.
9424
1400
1237
        my $router = $interface->{router};
9425
9426        # If its a zone delimiting router, reference interface in zone and v.v.
9427
1400
2907
        if ($router->{managed} or $router->{semi_managed}) {
9428
1158
1164
            $interface->{zone} = $zone;
9429
1158
1158
804
2365
            push @{ $zone->{interfaces} }, $interface;
9430        }
9431        else {
9432
9433            #If its an unmanaged router, reference router in zone and v.v.
9434
242
391
            next if $router->{zone}; # Traverse each unmanaged router only once.
9435
206
223
            $router->{zone} = $zone; # added only to prevent double traversal
9436
206
206
163
280
            push @{ $zone->{unmanaged_routers} }, $router;
9437
9438            # Recursively add adjacent networks.
9439
206
206
179
257
            for my $out_interface (@{ $router->{interfaces} }) {
9440
472
1009
                next if $out_interface eq $interface;# Ignore IF we came from.
9441
266
400
                next if $out_interface->{disabled};
9442
266
497
                set_zone1($out_interface->{network}, $zone, $out_interface);
9443            }
9444        }
9445    }
9446
1112
1514
    return;
9447}
9448
9449##############################################################################
9450# Purpose  : Collect zones connected by semi_managed devices into a cluster.
9451# Comments : Tunnel_zones are not included in zone clusters, because
9452#               - it is useless in rules and
9453#               - we would get inconsistent owner since zone of tunnel
9454#                 doesn't inherit from area.
9455sub set_zone_cluster {
9456
882
0
825
    my ($zone, $in_interface, $zone_aref) = @_;
9457
9458    # Reference zone in cluster object and vice versa
9459
882
1586
    push @$zone_aref, $zone if !$zone->{is_tunnel};
9460
882
846
    $zone->{zone_cluster} = $zone_aref;
9461
9462
882
2068
    my $private1 = $zone->{private} || 'public';
9463
9464    # Find zone interfaces connected to semi-managed routers...   
9465
882
882
665
1097
    for my $interface (@{ $zone->{interfaces} }) {
9466
1158
1999
        next if $interface eq $in_interface;
9467
1132
1579
        next if $interface->{main_interface};
9468
1075
929
        my $router = $interface->{router};
9469
1075
2148
        next if $router->{managed};
9470
19
33
        next if $router->{active_path};
9471
19
28
        local $router->{active_path} = 1;
9472
9473        # Process adjacent zones...
9474
19
19
18
25
        for my $out_interface (@{ $router->{interfaces} }) {
9475
46
96
            next if $out_interface eq $interface;
9476
27
25
            my $next = $out_interface->{zone};
9477
27
46
            next if $next->{zone_cluster}; #traverse zones only once
9478
26
45
            next if $out_interface->{main_interface};
9479
9480           # Check for equal private status.  
9481
26
68
           my $private2 = $next->{private} || 'public';
9482
26
39
            $private1 eq $private2 or
9483                err_msg("Zones connected by $router->{name}",
9484                        " must all have identical 'private' status\n",
9485                        " - $zone->{name}: $private1\n",
9486                        " - $next->{name}: $private2");
9487
9488            # Add adjacent zone recursively.
9489
26
52
            set_zone_cluster($next, $out_interface, $zone_aref);
9490        }
9491    }
9492
882
1009
    return;
9493}
9494
9495# Two zones are zone_eq, if
9496# - zones are equal or
9497# - both belong to the same zone cluster.
9498sub zone_eq {
9499
12
0
16
    my ($zone1, $zone2) = @_;
9500
12
97
    return(($zone1->{zone_cluster} || $zone1) eq
9501           ($zone2->{zone_cluster} || $zone2));
9502}
9503
9504###############################################################################
9505# Purpose  : Collect zones and managed routers of an area object and set a
9506#            reference to the area in its zones and routers.
9507#            For areas with defined borders: Keep track of area borders found
9508#            during area traversal.
9509#            For anchor/auto_border areas: fill {border} and {inclusive_border}
9510#            arrays.
9511# Returns  : undef (or aref of interfaces, if invalid path was found).
9512sub set_area1 {
9513
186
0
179
    my ($obj, $area, $in_interface) = @_;
9514
9515
186
376
    return if $obj->{areas}->{$area}; # Found a loop.
9516
9517
182
272
    $obj->{areas}->{$area} = $area;# Find duplicate/overlapping areas or loops
9518
9519
182
219
    my $is_zone = is_zone($obj);
9520
9521    # Reference zones and managed routers in the corresponding area
9522
182
336
    if ($is_zone) {
9523
125
184
        if (!$obj->{is_tunnel}) {
9524
125
125
91
164
            push @{ $area->{zones} }, $obj;
9525        }
9526    }
9527    elsif ($obj->{managed} || $obj->{routing_only}) {
9528
57
57
46
83
        push @{ $area->{managed_routers} }, $obj;
9529    }
9530
9531
182
177
    my $auto_border  = $area->{auto_border};
9532
182
154
    my $lookup       = $area->{intf_lookup};
9533
9534
182
182
136
220
    for my $interface (@{ $obj->{interfaces} }) {
9535
9536        # Ignore interface we came from.
9537
301
641
        next if $interface eq $in_interface;
9538
9539        # No further traversal at secondary interfaces
9540
139
209
        next if $interface->{main_interface};
9541
9542        # For areas with defined borders, check if border was found...
9543
135
287
        if ($lookup->{$interface}) {
9544
13
12
            my $is_inclusive = $interface->{is_inclusive};
9545
9546            # Reached border from wrong side or border classification wrong.
9547
13
59
            if ($is_inclusive->{$area} xor !$is_zone) {               
9548
2
7
                return [ $interface ]; # will be collected to show invalid path
9549            }
9550
9551            # ...mark found border in lookup hash.
9552
11
19
            $lookup->{$interface} = 'found';
9553
11
16
            next;
9554        }
9555
9556        # For auto_border areas, just collect border/inclusive_border interface
9557        elsif ($auto_border) {
9558
6
9
            if ($interface->{is_border}) {
9559
2
2
2
4
                push(@{ $area->{$is_zone ? 'border' : 'inclusive_border'} },
9560                     $interface);
9561
2
3
                next;
9562            }
9563        }
9564
9565        # Proceed traversal with next element
9566
120
166
        my $next = $interface->{$is_zone ? 'router' : 'zone'};
9567
120
212
        if (my $err_path = set_area1($next, $area, $interface)) {
9568
3
4
            push @$err_path, $interface; # collect interfaces of invalid path
9569
3
7
            return $err_path;
9570        }
9571    }
9572
177
449
    return;
9573}
9574
9575###############################################################################
9576# Purpose : Distribute router_attributes from the area definition to the managed
9577#           routers of the area.
9578sub inherit_router_attributes {
9579
66
0
64
    my ($area) = @_;
9580
9581    # Check for attributes to be inherited.
9582
66
126
    my $attributes = $area->{router_attributes} or return;
9583
7
14
    $attributes->{owner} and keys %$attributes == 1 and return; # handled later
9584
9585    #Process all managed routers of the area inherited from.
9586
7
7
7
10
    for my $router (@{ $area->{managed_routers} }) {
9587
6
12
        for my $key (keys %$attributes) {
9588
9589
12
19
            next if $key eq 'owner'; # Owner is handled in propagate_owners.
9590
9591            # if attribute exists in router (router or smaller area definition)
9592
12
11
            my $val = $attributes->{$key};
9593
12
17
            if (my $r_val = $router->{$key}) {
9594
8
37
                if (   $r_val eq $val  # warn, if attributes are equal
9595                    || ref $r_val eq 'ARRAY' && ref $val eq 'ARRAY'
9596                    && aref_eq($r_val, $val))
9597                {
9598
1
6
                    warn_msg(
9599                        "Useless attribute '$key' at $router->{name},\n",
9600                        " it was already inherited from $attributes->{name}");
9601                }
9602            }
9603
9604            # Add attribute to the router object if not yet set.
9605            else {
9606
4
10
                $router->{$key} = $val;
9607            }
9608        }
9609    }
9610
7
8
    return;
9611}
9612
9613###############################################################################
9614# Purpose : Returns true if nat hashes are equal.
9615sub nat_equal {
9616
23
0
22
    my ($nat1, $nat2) = @_;
9617
9618    # Check whether nat attributes are different...
9619
23
26
    for my $attr (qw(ip mask dynamic hidden identity)) {
9620
50
184
        return if defined $nat1->{$attr} xor defined $nat2->{$attr};
9621
37
61
        next if !defined $nat1->{$attr};# none of the Nats holds the attribute
9622
20
49
        return if $nat1->{$attr} ne $nat2->{$attr};# values of attribute differ
9623    }
9624
9625    # ...return true if no difference found.
9626
3
7
    return 1;
9627}
9628##############################################################################
9629# Purpose : 1. Generate warning if NAT value of two objects hold the same
9630#              attributes.
9631#           2. Mark occurence of identity NAT that masks inheritance.
9632#              This is used later to warn on useless identity NAT.
9633sub check_useless_nat {
9634
23
0
29
    my ($nat_tag, $nat1, $nat2, $obj1, $obj2) = @_;
9635
23
30
    if (nat_equal($nat1, $nat2)) {
9636
3
12
        warn_msg("Useless nat:$nat_tag at $obj2->{name},\n",
9637                 " it is already inherited from $obj1->{name}");
9638    }
9639
23
35
    if ($nat2->{identity}) {
9640
10
12
        $nat2->{is_used} = 1;
9641    }
9642
23
36
    return;
9643}
9644
9645##############################################################################
9646# Purpose : Distribute NAT from area to zones.
9647sub inherit_area_nat {
9648
9649
66
0
67
    my ($area) = @_;
9650
66
154
    my $hash = $area->{nat} or return;
9651
9652    # Process every nat definition of area.
9653
5
10
    for my $nat_tag (sort keys %$hash) {
9654
6
7
        my $nat = $hash->{$nat_tag};
9655
9656        # Distribute nat definitions to every zone of area.
9657
6
6
7
8
        for my $zone (@{ $area->{zones} }) {
9658
9659            # Skip zone, if NAT tag exists in zone already...
9660
10
17
            if (my $z_nat = $zone->{nat}->{$nat_tag}) {
9661
9662                # ... and warn if zones NAT value holds the same attributes.
9663
4
7
                check_useless_nat($nat_tag, $nat, $z_nat, $area, $zone);
9664
4
8
                next;
9665            }
9666
9667            # Store NAT definition in zone otherwise
9668
6
14
            $zone->{nat}->{$nat_tag} = $nat;
9669#           debug "$zone->{name}: $nat_tag from $area->{name}";
9670        }
9671    }
9672
5
8
    return;
9673}
9674
9675###############################################################################
9676# Purpose : Assure that areas are processed in the right order and distribute
9677#           area attributes to zones and managed routers.   
9678sub inherit_attributes_from_area {
9679
9680    # Areas can be nested. Proceed from small to larger ones.
9681
337
29
29
29
0
556
24
34
43
    for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) {
9682
66
95
        inherit_router_attributes($area);
9683
66
90
        inherit_area_nat($area);
9684    }
9685
337
323
    return;
9686}
9687
9688###############################################################################
9689# Purpose  : Distributes NAT from aggregates and networks to other networks
9690#            in same zone, that are in subnet relation.
9691#            If a network A is subnet of multiple networks B < C,
9692#            then NAT of B is used.
9693sub inherit_nat_to_subnets_in_zone {
9694
106
0
113
    my ($net_or_zone, $zone) = @_;
9695
97
148
    my ($ip1, $mask1) = is_network($net_or_zone)
9696
106
131
                      ? @{$net_or_zone}{qw(ip mask)}
9697                      : (0, 0);
9698
106
129
    my $hash = $net_or_zone->{nat};
9699
106
215
    for my $nat_tag (sort keys %$hash) {
9700
136
159
        my $nat = $hash->{$nat_tag};
9701#        debug "inherit $nat_tag from $net_or_zone->{name}";
9702
9703        # Distribute nat definitions to every subnet of supernet, aggregate or zone.
9704
136
136
98
175
        for my $network (@{ $zone->{networks} }) {
9705
248
248
174
294
            my ($ip2, $mask2) = @{$network}{qw(ip mask)};
9706
9707            # Only process subnets.
9708
248
539
            $mask2 > $mask1 or next;
9709
55
73
            match_ip($ip2, $ip1, $mask1) or next;
9710
9711            # Skip network, if NAT tag exists in network already...
9712
33
90
            if (my $n_nat = $network->{nat}->{$nat_tag}) {
9713
9714                # ... and warn if networks NAT value holds the
9715                # same attributes.
9716
19
29
                check_useless_nat($nat_tag, $nat, $n_nat, $net_or_zone, $network);
9717            }
9718
9719            elsif ($network->{ip} eq 'bridged' and not $nat->{identity}) {
9720
0
0
                err_msg("Must not inherit nat:$nat_tag at bridged",
9721                        " $network->{name} from $net_or_zone->{name}");
9722            }
9723
9724            # Copy NAT defintion; append name of network.
9725            else {
9726
14
69
                my $sub_nat = {
9727                    %$nat,
9728
9729                    # Needed for error messages.
9730                    name => "nat:$nat_tag($network->{name})",
9731                };
9732
9733                # For static NAT from net_or_zone,
9734                # - merge IP from supernet and subnet,
9735                # - adapt mask to size of subnet
9736
14
33
                if (not $nat->{dynamic}) {
9737
9738                    # Take higher bits from NAT IP, lower bits from original IP.
9739
2
3
                    $sub_nat->{ip}  |= $ip2 & complement_32bit($mask1);
9740
2
2
                    $sub_nat->{mask} = $mask2;
9741                }
9742
9743
14
33
                $network->{nat}->{$nat_tag} = $sub_nat;                    
9744            }
9745        }
9746    }
9747
106
242
    return;
9748}
9749
9750sub inherit_nat_in_zone {
9751
337
0
367
    for my $zone (@zones) {
9752
9753        # Find all networks and aggregates of current zone,
9754        # that have NAT definitions.
9755
1129
882
1503
917
        my @nat_supernets = grep({ $_->{nat} }
9756
882
1428
                                 @{ $zone->{networks} },
9757
882
688
                                 values %{ $zone->{ipmask2aggregate} });
9758
9759        # Add zone object instead of aggregate 0/0, because NAT is stored
9760        # at zone in this case.
9761
882
1223
        my @nat_zone = $zone->{nat} ? ($zone) : ();
9762
9763        # Proceed from smaller to larger objects. (Bigger mask first.)
9764
882
13
1683
23
        for my $supernet (sort({ $b->{mask} <=> $a->{mask} } @nat_supernets),
9765                          @nat_zone)
9766        {
9767
106
142
            inherit_nat_to_subnets_in_zone($supernet, $zone);
9768        }   
9769    }
9770
337
317
    return;
9771}
9772
9773sub cleanup_after_inheritance {
9774
9775    # 1. Remove NAT entries from aggregates.
9776    #    These are only used during NAT inheritance.
9777    # 2. Remove identity NAT entries.
9778    #    These are only needed during NAT inheritance.
9779
337
0
378
    for my $network (@networks) {
9780
1165
1944
        my $href = $network->{nat} or next;
9781
111
166
        if ($network->{is_aggregate}) {
9782
2
2
            delete $network->{nat};
9783
2
5
            next;
9784        }
9785
109
166
        for my $nat_tag (keys %$href) {
9786
138
135
            my $nat_network = $href->{$nat_tag};
9787
138
330
            $nat_network->{identity} or next;
9788
10
13
            delete $href->{$nat_tag};
9789
10
33
            $nat_network->{is_used} or
9790                warn_msg("Useless identity nat:$nat_tag at $network->{name}");
9791        }
9792    }
9793
337
304
    return;
9794}
9795
9796sub inherit_attributes {
9797
337
0
467
    inherit_attributes_from_area();
9798
337
452
    inherit_nat_in_zone();
9799
337
421
    cleanup_after_inheritance();
9800
337
275
    return;
9801}
9802
9803##############################################################################
9804# Purpose  : Create a new zone object for every network without a zone
9805sub set_zones {
9806
9807    # Process networks without a zone
9808
337
0
389
    for my $network (@networks) {
9809
1112
1759
        next if $network->{zone};
9810
9811        # Create zone object with name of corresponding aggregate and ip 0/0.
9812
882
1913
        my $name = "any:[$network->{name}]";
9813
882
1507
        my $zone = new('Zone', name => $name, networks => []);
9814
882
857
        push @zones, $zone;
9815
9816        # Collect zone elements...
9817
882
1192
        set_zone1($network, $zone, 0);
9818
9819        # Mark zone which consists only of a loopback network.
9820
31
87
       $zone->{loopback} = 1
9821
882
1600
          if $network->{loopback} && @{ $zone->{networks} } == 1;
9822
9823        # Attribute {is_tunnel} is set only when zone has only tunnel networks.
9824
882
882
682
1422
        if (@{ $zone->{networks} }) {# tunnel networks arent referenced in zone
9825
873
884
            delete $zone->{is_tunnel};
9826        }
9827
9828        # Remove zone reference from unmanaged routers (no longer needed).
9829
882
1432
        if (my $unmanaged = $zone->{unmanaged_routers}) {
9830
156
380
            delete $_->{zone} for @$unmanaged;
9831        }
9832
9833        # Remove private status, if 'public'
9834
882
2768
        if ($zone->{private} && $zone->{private} eq 'public') {
9835
881
1396
            delete $zone->{private};
9836        }
9837    }
9838
337
342
    return;
9839}
9840
9841##############################################################################
9842# Purpose  : Clusters zones connected by semi_managed routers. References of all
9843#            zones of a cluster are stored in the {zone_cluster} attribute of
9844#            the zones.
9845# Comments : The {zone_cluster} attribute is only set if the cluster has more
9846#            than one element.
9847sub cluster_zones {
9848
9849    # Process all unclustered zones.
9850
337
0
385
    for my $zone (@zones) {        
9851
882
1335
        next if $zone->{zone_cluster};
9852
9853        # Create a new cluster and collect its zones
9854
856
849
        my $cluster = [];
9855
856
1072
        set_zone_cluster($zone, 0, $cluster);
9856
9857        # delete clusters containing a single network only
9858
856
1930
        delete $zone->{zone_cluster} if 1 >= @$cluster;
9859
9860#       debug('cluster: ', join(',',map($_->{name}, @{$zone->{zone_cluster}})))
9861#           if $zone->{zone_cluster};
9862    }
9863
337
337
    return;
9864}
9865
9866###############################################################################
9867# Purpose  : Mark interfaces, which are border of some area, prepare consistency
9868#            check for attributes {border} and {inclusive_border}.
9869# Comments : Area labeled interfaces are needed to locate auto_borders.
9870sub prepare_area_borders {
9871
337
0
282
    my %has_inclusive_borders; # collects all routers with inclusive border IF
9872
9873    # Identify all interfaces which are border of some area
9874
337
391
    for my $area (@areas) {
9875
66
75
        for my $attribute (qw(border inclusive_border)) {
9876
132
317
            my $border = $area->{$attribute} or next;
9877
52
55
            for my $interface (@$border) {
9878
9879                # Reference delimited area in the interfaces attributes
9880
62
81
                $interface->{is_border} = $area; # used for auto borders
9881
62
159
                if ($attribute eq 'inclusive_border') {
9882
18
35
                    $interface->{is_inclusive}->{$area} = $area;
9883
9884                    # Collect routers with inclusive border interface
9885
18
18
                    my $router = $interface->{router};
9886
18
54
                    $has_inclusive_borders{$router} = $router;
9887                }
9888            }
9889        }
9890    }
9891
337
406
    return \%has_inclusive_borders;
9892}
9893
9894###############################################################################
9895# Purpose  : Collect zones, routers (and interfaces, if no borders defined)
9896#            of an area.
9897# Returns  : undef (or 1, if error was shown)
9898sub set_area {
9899
66
0
72
    my ($obj, $area, $in_interface) = @_;
9900
66
123
    if (my $err_path = set_area1($obj, $area, $in_interface)) {
9901
9902        # Print error path, if errors occurred
9903
2
4
        push @$err_path, $in_interface if $in_interface;
9904
2
2
        my $err_intf = $err_path->[0];
9905
2
2
        my $is_inclusive = $err_intf->{is_inclusive};
9906
2
6
        my $err_obj = $err_intf->{$is_inclusive->{$area} ? 'router' : 'zone'};
9907
2
7
        my $in_loop = $err_obj->{areas}->{$area} ? ' in loop' : '';
9908
7
20
        err_msg("Inconsistent definition of $area->{name}", $in_loop, ".\n",
9909                " It is reached from outside via this path:\n",
9910
2
7
                " - ", join("\n - ", map { $_->{name} } reverse @$err_path));
9911
2
4
        return 1;
9912    }
9913
64
66
    return;
9914}
9915
9916###############################################################################s
9917# Purpose  : Set up area objects, assure proper border definitions.
9918sub set_areas {
9919
337
0
388
    for my $area (@areas) {
9920
66
101
        $area->{zones} = [];
9921
66
115
        if (my $network = $area->{anchor}) {
9922
17
30
            set_area($network->{zone}, $area, 0);
9923        }
9924        else {
9925
9926            # For efficient look up if some IF is a border of current area.
9927
49
70
            my $lookup = $area->{intf_lookup} = {};
9928
9929
49
46
            my $start;
9930            my $obj1;
9931
9932            # Collect all area delimiting interfaces in border lookup array
9933
49
53
            for my $attr (qw(border inclusive_border)) {
9934
98
204
                my $borders = $area->{$attr} or next;
9935
52
52
52
110
                @{$lookup}{@$borders} = @$borders;
9936
52
89
                next if $start;
9937
9938                # identify start interface and direction for area traversal
9939
49
52
                $start = $borders->[0];
9940
49
98
                $obj1 = $attr eq 'border'
9941                      ? $start->{zone} # proceed with zone
9942                      : $start->{router}; # proceed with router
9943            }
9944
9945            # Collect zones and routers of area and keep track of borders found.
9946
49
80
            $lookup->{$start} = 'found';
9947
49
76
            my $err = set_area($obj1, $area, $start);
9948
49
74
            next if $err;
9949
9950            # Assert that all borders were found.
9951
47
51
            for my $attr (qw(border inclusive_border)) {
9952
94
200
                my $borders = $area->{$attr} or next;
9953
49
59
65
206
                my @bad_intf = grep { $lookup->{$_} ne 'found' } @$borders
9954                    or next;
9955
1
4
                err_msg("Invalid $attr of $area->{name}:\n - ",
9956
1
3
                        join("\n - ", map { $_->{name} } @bad_intf));
9957
2
6
                $area->{$attr} =
9958
1
2
                    [ grep { $lookup->{$_} eq 'found' } @$borders ];
9959            }
9960        }
9961
9962        # Check whether area is empty (= consist of a single router)
9963
64
64
55
162
        @{ $area->{zones} } or
9964            warn_msg("$area->{name} is empty");
9965
9966#     debug("$area->{name}:\n ", join "\n ", map $_->{name}, @{$area->{zones}});
9967    }
9968
337
286
    return;
9969}
9970
9971###############################################################################
9972# Purpose : Find subset relation between areas, assure that no duplicate or
9973#           overlapping areas exist
9974sub find_subset_relations {
9975
337
0
264
    my %seen; # key:contained area, value: containing area
9976
9977    # Process all zones contained by one or more areas
9978
337
383
    for my $zone (@zones) {
9979
882
1518
        $zone->{areas} or next;
9980
9981        # Sort areas containing zone by ascending size
9982
32
32
32
97
28
32
93
250
        my @areas = sort({ @{ $a->{zones} } <=> @{ $b->{zones} } ||
9983                           $a->{name} cmp $b->{name} }#equal size? sort by name
9984
97
85
                         values %{ $zone->{areas} }) or next; # Skip empty hash.
9985
9986        # Take the smallest area.
9987
97
97
        my $next = shift @areas;
9988
9989
97
195
        while(@areas) {
9990
28
24
            my $small = $next;
9991
28
23
            $next = shift @areas;
9992
28
84
            next if $seen{$small}->{$next};# Already identified in other zone.
9993
9994            # Check that each zone of $small is part of $next.
9995
18
18
            my $ok = 1;
9996
18
18
17
24
            for my $zone (@{ $small->{zones} }) {
9997
28
70
                if(!$zone->{areas}->{$next}) {
9998
1
1
                    $ok = 0;
9999
1
5
                    err_msg("Overlapping $small->{name} and $next->{name}");
10000
1
1
                    last;
10001                }
10002            }
10003
10004            # check for duplicates
10005
18
30
            if ($ok) {
10006
17
17
17
13
21
28
                if (@{ $small->{zones} } == @{ $next->{zones} }) {
10007
1
60
                    err_msg("Duplicate $small->{name} and $next->{name}");
10008                }
10009
10010                # reference containing area
10011                else {
10012
16
23
                    $small->{subset_of} = $next;
10013#                    debug "$small->{name} < $next->{name}";
10014                }
10015            }
10016
10017            #keep track of processed areas
10018
18
61
            $seen{$small}->{$next} = 1;
10019        }
10020    }
10021
337
423
    return;
10022}
10023
10024#############################################################################
10025# Purpose  : Check, that area subset relations hold for routers:
10026#          : Case 1: If a router R is located inside areas A1 and A2 via
10027#            'inclusive_border', then A1 and A2 must be in subset relation.
10028#          : Case 2: If area A1 and A2 are in subset relation and A1 includes R,
10029#            then A2 also needs to include R either from 'inclusive_border' or
10030#            R is surrounded by zones located inside A2.
10031# Comments : This is needed to get consistent inheritance with
10032#            'router_attributes'.
10033sub check_routers_in_nested_areas {
10034
10035
337
0
325
    my ($has_inclusive_borders) = @_;
10036    # Case 1: Identify routers contained by areas via 'inclusive_border'
10037
337
876
    for my $router (sort by_name values %$has_inclusive_borders) {
10038
10039        # Sort all areas having this router as inclusive_border by size.
10040
3
4
        my @areas =  
10041
3
3
12
2
12
26
            sort({ @{ $a->{zones} } <=> @{ $b->{zones} } || # ascending order
10042                       $a->{name} cmp $b->{name} } # equal size? sort by name
10043
12
14
                 values %{ $router->{areas} });
10044
10045        # Take the smallest area.
10046
12
12
        my $next = shift @areas;
10047
10048        # Pairwisely check containing areas for subset relation.
10049
12
30
        while(@areas) {
10050
3
7
            my $small = $next;
10051
3
3
            $next = shift @areas;
10052
3
9
            my $big = $small->{subset_of} || ''; # extract containing area
10053
3
13
            next if $next eq $big;
10054
1
7
            err_msg("$small->{name} and $next->{name} must be",
10055                    " in subset relation,\n because both have",
10056                    " $router->{name} as 'inclusive_border'");
10057        }
10058    }
10059
10060    # Case 2: Identify areas in subset relation
10061
337
426
    for my $area (@areas) {
10062
66
161
        my $big = $area->{subset_of} or next;
10063
10064        # Assure routers of the subset area to be located in containing area too
10065
16
16
16
35
        for my $router (@{ $area->{managed_routers} }) {
10066
8
26
            next if $router->{areas}->{$big};
10067
1
6
            err_msg("$router->{name} must be located in $big->{name},\n",
10068                    " because it is located in $area->{name}\n",
10069                    " and both areas are in subset relation\n",
10070                    " (use attribute 'inclusive_border')");
10071        }
10072    }
10073
337
309
    return;
10074}
10075
10076##############################################################################
10077# Purpose  : Delete unused attributes in area objects.
10078sub clean_areas {
10079
337
0
387
    for my $area (@areas) {
10080
66
98
        delete $area->{intf_lookup};
10081
66
66
57
117
        for my $interface (@{ $area->{border} }) {
10082
44
42
            delete $interface->{is_border};
10083
44
83
            delete $interface->{is_inclusive};
10084        }
10085    }
10086
337
281
    return;
10087}
10088
10089###############################################################################
10090# Purpose  : Create zones and areas.
10091sub set_zone {
10092
337
0
456
    progress('Preparing security zones and areas');
10093
337
474
    set_zones();
10094
337
492
    cluster_zones();
10095
337
489
    check_no_in_acl(); #TODO: place somewhere else?  
10096
337
472
    my $crosslink_routers = check_crosslink(); #TODO: place somewhere else?
10097
337
494
    cluster_crosslink_routers($crosslink_routers); #TODO: place somewhere else?
10098
337
443
    my $has_inclusive_borders = prepare_area_borders();
10099
337
481
    set_areas();
10100
337
448
    find_subset_relations();
10101
337
466
    check_routers_in_nested_areas($has_inclusive_borders);
10102
337
427
    clean_areas(); # delete unused attributes
10103
337
464
    link_aggregates();
10104
337
432
    inherit_attributes();
10105
337
513
    return;
10106}
10107
10108####################################################################
10109# Virtual interfaces
10110####################################################################
10111
10112# Interfaces with identical virtual IP must be located inside the same loop.
10113sub check_virtual_interfaces  {
10114
332
0
289
    my %seen;
10115
332
382
    for my $interface (@virtual_interfaces) {
10116
72
115
        my $related = $interface->{redundancy_interfaces} or next;
10117
10118        # Loops inside a security zone are not known
10119        # and therefore can't be checked.
10120
72
64
        my $router = $interface->{router};
10121
72
164
        next if not($router->{managed} or $router->{semi_managed});
10122
10123
59
114
        $seen{$related} and next;
10124
28
42
        $seen{$related} = 1;
10125
10126
28
20
        my $err;
10127
28
33
        for my $v (@$related) {
10128
59
117
            if (not $v->{router}->{loop}) {
10129
0
0
                err_msg("Virtual IP of $v->{name}\n",
10130                        " must be located inside cyclic sub-graph");
10131
0
0
                $err = 1;
10132            }
10133        }
10134
28
50
        next if $err;
10135
4
59
7
91
        equal(map { $_->{loop} } @$related)
10136          or err_msg("Virtual interfaces\n ",
10137
28
33
                     join(', ', map({ $_->{name} } @$related)),
10138                     "\n must all be part of the same cyclic sub-graph");
10139    }
10140
332
376
    return;
10141}
10142
10143####################################################################
10144# Check pathrestrictions
10145####################################################################
10146
10147sub check_pathrestrictions {
10148  RESTRICT:
10149
332
0
576
    for my $restrict (values %pathrestrictions) {
10150
29
34
        my $elements = $restrict->{elements};
10151
29
47
        next if !@$elements;
10152
29
22
        my $deleted;
10153
29
37
        for my $obj (@$elements) {
10154
10155            # Interfaces with pathrestriction need to be located
10156            # inside or at the border of cyclic graphs.
10157
60
155
            if (
10158                not(   $obj->{loop}
10159                    || $obj->{router}->{loop}
10160                    || $obj->{zone}->{loop}
10161                    || $obj->{disabled})
10162              )
10163            {
10164
0
0
                delete $obj->{path_restrict};
10165
0
0
                warn_msg("Ignoring $restrict->{name} at $obj->{name}\n",
10166                         " because it isn't located inside cyclic graph");
10167
0
0
                $obj = undef;
10168
0
0
                $deleted = 1;
10169            }
10170        }
10171
29
46
        if ($deleted) {
10172
0
0
0
0
            $elements = $restrict->{elements} = [ grep { $_ } @$elements ];
10173
0
0
            if (1 == @$elements) {
10174
0
0
                $elements = $restrict->{elements} = [];
10175            }
10176        }
10177
29
44
        next if !@$elements;
10178
10179        # Check for useless pathrestriction where all interfaces
10180        # are located inside a loop with all routers unmanaged.
10181        #
10182        # Some router is managed.
10183
29
60
32
179
        grep({ $_->{router}->{managed} || $_->{router}->{routing_only} }
10184             @$elements) and next;
10185
10186        # Different zones or zone_clusters, hence some router is managed.
10187
6
13
13
8
32
18
        equal(map { $_->{zone_cluster} || $_ } map { $_->{zone} } @$elements)
10188            or next;
10189
10190        # If there exists some neighbour zone or zone_cluster, located
10191        # inside the same loop, then some router is managed.
10192        # Interface is known to have attribute {loop},
10193        # because it is unmanaged and has pathrestriction.
10194
6
8
        my $element = $elements->[0];
10195
6
7
        my $loop = $element->{loop};
10196
6
5
        my $zone = $element->{zone};
10197
6
11
        my $zone_cluster = $zone->{zone_cluster} || [ $zone ];
10198
6
11
        for my $zone1 (@$zone_cluster) {
10199
7
7
4
12
            for my $interface (@{ $zone->{interfaces} }) {
10200
12
7
                my $router = $interface->{router};
10201
12
12
12
14
                for my $interface2 (@{ $router->{interfaces} }) {
10202
22
21
                    my $zone2 = $interface2->{zone};
10203
22
40
                    next if $zone2 eq $zone;
10204
14
25
                    if (my $cluster2 = $zone2->{zone_cluster}) {
10205
9
26
                        next if $cluster2 eq $zone_cluster;
10206                    }
10207
7
12
                    if (my $loop2 = $zone2->{loop}) {
10208
5
16
                        if ($loop eq $loop2) {
10209
10210                            # Found other zone in same loop.
10211
5
15
                            next RESTRICT;
10212                        }
10213                    }
10214                }
10215            }
10216        }
10217
10218
1
4
        warn_msg("Useless $restrict->{name}.\n",
10219                 " All interfaces are unmanaged and",
10220                 " located inside the same security zone"
10221            );
10222
1
4
        $restrict->{elements} = [];
10223    }
10224
332
29
29
408
20
48
    push @pathrestrictions, grep({ @{ $_->{elements} } }
10225                                 values %pathrestrictions);
10226
332
295
    return;
10227}
10228
10229####################################################################
10230# Optimize a class of pathrestrictions.
10231# Find partitions of cyclic graphs that are separated
10232# by pathrestrictions.
10233# This allows faster graph traversal.
10234# When entering a partition, we can already decide,
10235# if end of path is reachable or not.
10236####################################################################
10237
10238sub traverse_loop_part {
10239
332
0
346
    my ($obj, $in_interface, $mark, $seen) = @_;
10240
332
587
    return if $obj->{reachable_part}->{$mark};
10241
282
375
    return if $obj->{active_path};
10242
282
343
    local $obj->{active_path} = 1;
10243
10244    # Mark $obj as member of partition.
10245
282
309
    $obj->{reachable_part}->{$mark} = 1;
10246#    debug "$obj->{name} in loop part $mark";
10247
282
308
    my $is_zone = is_zone($obj);
10248
282
282
231
333
    for my $interface (@{ $obj->{interfaces} }) {
10249
936
1665
        next if $interface eq $in_interface;
10250
654
967
        next if $interface->{main_interface};
10251
402
611
        if (my $hash = $seen->{$interface}) {
10252
119
150
            my $current = $is_zone ? 'zone' : 'router';
10253
119
214
            $hash->{$current} = $mark;
10254        }
10255        else {
10256
283
432
            next if !$interface->{loop};
10257
227
292
            my $next = $interface->{$is_zone ? 'router' : 'zone'};
10258
227
297
            traverse_loop_part($next, $interface, $mark, $seen);
10259        }
10260    }
10261
282
452
    return;
10262}
10263
10264# Find partitions of a cyclic graph that are separated by pathrestrictions.
10265# Mark each found partition with a distinct number.
10266sub optimize_pathrestrictions {
10267
332
0
291
    my $mark = 1;
10268
332
355
    for my $restrict (@pathrestrictions) {
10269
56
59
        my $elements = $restrict->{elements};
10270
10271        # Create a hash with all elements as key.
10272        # Used for efficient lookup, if some interface
10273        # is part of current pathrestriction.
10274        # Value is an initially empty hash.
10275        # Keys 'router' and 'zone' are added during traversal.
10276        # Key indicates if element was reached from router or network.
10277        # Value is $mark of the adjacent partition.
10278
56
61
        my $seen = {};
10279
56
62
        for my $interface (@$elements) {
10280
117
238
            $seen->{$interface} = {};
10281        }
10282
10283        # Traverse loop starting from each element of pathrestriction
10284        # in both directions.
10285
56
52
        my $start_mark = $mark;
10286
56
58
        for my $interface (@$elements) {
10287
117
142
            my $reached = $seen->{$interface};
10288
117
117
            for my $direction (qw(zone router)) {
10289
10290                # This side of the interface has already been entered
10291                # from some previously found partition.
10292
234
423
                next if $reached->{$direction};
10293
115
112
                my $obj = $interface->{$direction};
10294
10295                # Ignore interface at border of loop in direction
10296                # leaving the loop.
10297
115
187
                if (!$obj->{loop}) {
10298
10
13
                    $reached->{$direction} = 'none';
10299
10
13
                    next;
10300                }
10301
105
113
                $reached->{$direction} = $mark;
10302
105
126
                traverse_loop_part($obj, $interface, $mark, $seen);
10303
105
137
                $mark++;
10304            }
10305        }
10306
10307        # Analyze found partitions.
10308
10309        # If only a single partition was found, nothing can be optimized.
10310
56
114
        next if $mark <= $start_mark + 1;
10311
10312        # No outgoing restriction needed for a pathrestriction surrounding a
10313        # single zone. A rule from zone to zone would be unenforceable anyway.
10314        #
10315        # But this restriction is needed for one special case:
10316        # src=zone, dst=interface:r.zone
10317        # We must not enter router:r from outside the zone.
10318#        if (equal(map { $_->{zone} } @$elements)) {
10319#            $seen->{$_}->{router} = 'none' for @$elements;
10320#        }
10321
10322        # Collect interfaces at border of newly found partitions.
10323
47
45
        my $has_interior;
10324
47
48
        for my $interface (@$elements) {
10325
98
121
            my $reached = $seen->{$interface};
10326
10327            # Check for pathrestriction inside a partition.
10328
98
239
            if ($reached->{zone} eq $reached->{router} &&
10329                $reached->{zone} ne 'none')
10330            {
10331
0
0
                $has_interior++;
10332            }
10333            else {
10334
98
97
                for my $direction (qw(zone router)) {
10335
196
194
                    my $mark = $reached->{$direction};
10336
196
263
                    next if $mark eq 'none';
10337
196
169
                    my $obj = $interface->{$direction};
10338
196
196
155
604
                    push @{ $interface->{reachable_at}->{$obj} }, $mark;
10339#                    debug "$interface->{name}: $direction $mark";
10340                }
10341            }
10342        }
10343
10344        # Original pathrestriction is needless, if all interfaces are
10345        # border of some partition. The restriction is implemented by
10346        # the new attribute {reachable_at}.
10347
47
78
        if (!$has_interior) {
10348
47
54
            for my $interface (@$elements) {
10349#                debug "remove $restrict->{name} from $interface->{name}";
10350
98
139
                aref_delete($interface->{path_restrict}, $restrict) or
10351                    internal_err("Can't remove $restrict->{name}",
10352                                 " from $interface->{name}");
10353
10354                # Delete empty array to speed up checks in cluster_path_mark.
10355
98
98
77
161
                if (!@{ $interface->{path_restrict} }) {
10356
95
242
                    delete $interface->{path_restrict};
10357                }
10358            }
10359        }
10360        else {
10361#            debug "Can't opt. $restrict->{name}, has $has_interior interior";
10362        }
10363    }
10364
332
300
    return;
10365}
10366
10367####################################################################
10368# Set paths for efficient topology traversal
10369####################################################################
10370
10371# Parameters:
10372# $obj: a managed or semi-managed router or a zone
10373# $to_zone1: interface of $obj; go this direction to reach zone1
10374# $distance: distance to zone1
10375# Return values:
10376# 1. maximal value of $distance used in current subtree.
10377# 2.
10378# - undef: found path is not part of a loop
10379# - loop-marker:
10380#   - found path is part of a loop
10381#   - a hash, which is referenced by all members of the loop
10382#     with this attributes:
10383#     - exit: that node of the loop where zone1 is reached
10384#     - distance: distance of the exit node + 1.
10385sub setpath_obj;
10386
10387sub setpath_obj {
10388
1505
0
1427
    my ($obj, $to_zone1, $distance) = @_;
10389
10390#    debug("--$distance: $obj->{name} --> ". ($to_zone1 && $to_zone1->{name}));
10391
1505
2123
    if ($obj->{active_path}) {
10392
10393        # Found a loop; this is possibly exit of the loop to zone1.
10394        # Generate unique loop marker which references this object.
10395        # Distance is needed for cluster navigation.
10396        # We need a copy of the distance value inside the loop marker
10397        # because distance at object is reset later to the value of the
10398        # cluster exit object.
10399        # We must use an intermediate distance value for cluster_navigation
10400        # to work.
10401
119
123
        my $new_distance = $obj->{distance} + 1;
10402
119
278
        my $loop = $to_zone1->{loop} = {
10403            exit     => $obj,
10404            distance => $new_distance,
10405        };
10406
119
187
        return ($new_distance, $loop);
10407    }
10408
10409    # Mark current path for loop detection.
10410
1386
1690
    local $obj->{active_path} = 1;
10411
1386
1332
    $obj->{distance} = $distance;
10412
1386
1045
    my $max_distance = $distance;
10413
10414
1386
1527
    my $get_next = is_router($obj) ? 'zone' : 'router';
10415
1386
1386
1204
1718
    for my $interface (@{ $obj->{interfaces} }) {
10416
10417        # Ignore interface where we reached this obj.
10418
2316
4599
        next if $interface eq $to_zone1;
10419
10420        # Ignore interface which is the other entry of a loop which is
10421        # already marked.
10422
1277
1859
        next if $interface->{loop};
10423
1158
1126
        my $next = $interface->{$get_next};
10424
10425        # Increment by 2 because we need an intermediate value above.
10426
1158
1981
        (my $max, my $loop) = setpath_obj($next, $interface, $distance + 2);
10427
1158
1726
        $max_distance = $max if $max > $max_distance;
10428
1158
1270
        if ($loop) {
10429
316
279
            my $loop_obj = $loop->{exit};
10430
10431            # Found exit of loop in direction to zone1.
10432
316
636
            if ($obj eq $loop_obj) {
10433
10434                # Mark with a different marker linking to itself.
10435                # If current loop is part of a cluster,
10436                # this marker will be overwritten later.
10437                # Otherwise this is the exit of a cluster of loops.
10438
61
237
                $obj->{loop} ||= { exit => $obj, distance => $distance, };
10439            }
10440
10441            # Found intermediate loop node which was marked before.
10442            elsif (my $loop2 = $obj->{loop}) {
10443
58
103
                if ($loop ne $loop2) {
10444
58
83
                    if ($loop->{distance} < $loop2->{distance}) {
10445
10
9
                        $loop2->{redirect} = $loop;
10446
10
13
                        $obj->{loop}       = $loop;
10447                    }
10448                    else {
10449
48
60
                        $loop->{redirect} = $loop2;
10450                    }
10451                }
10452            }
10453
10454            # Found intermediate loop node.
10455            else {
10456
197
222
                $obj->{loop} = $loop;
10457            }
10458
316
561
            $interface->{loop} = $loop;
10459        }
10460        else {
10461
10462            # Continue marking loop-less path.
10463
842
1483
            $interface->{main} = $obj;
10464        }
10465    }
10466
1386
3117
    if ($obj->{loop} and $obj->{loop}->{exit} ne $obj) {
10467
197
372
        return ($max_distance, $obj->{loop});
10468
10469    }
10470    else {
10471
1189
1288
        $obj->{main} = $to_zone1;
10472
1189
1923
        return $max_distance;
10473    }
10474}
10475
10476# Find cluster of directly connected loops.
10477# Find exit node of the cluster in direction to zone1;
10478# Its loop attribute has a reference to the node itself.
10479# Add this exit node as marker to all loops belonging to the cluster.
10480sub set_loop_cluster {
10481
316
0
232
    my ($loop) = @_;
10482
316
409
    if (my $marker = $loop->{cluster_exit}) {
10483
197
190
        return $marker;
10484    }
10485    else {
10486
119
104
        my $exit = $loop->{exit};
10487
10488        # Exit node has loop marker which references the node itself.
10489
119
252
        if ($exit->{loop} eq $loop) {
10490
10491#           debug("Loop $exit->{name},$loop->{distance} is in cluster $exit->{name}");
10492
58
96
            return $loop->{cluster_exit} = $exit;
10493        }
10494        else {
10495
61
120
            my $cluster = set_loop_cluster($exit->{loop});
10496
10497#           debug("Loop $exit->{name},$loop->{distance} is in cluster $cluster->{name}");
10498
61
98
            return $loop->{cluster_exit} = $cluster;
10499        }
10500    }
10501}
10502
10503sub setpath {
10504
337
0
481
    progress('Preparing fast path traversal');
10505
10506
337
554
    @zones or fatal_err("Topology seems to be empty");
10507
332
690
372
1711
    my @path_routers = grep { $_->{managed} || $_->{semi_managed} } @routers;
10508
332
314
    my $start_distance = 0;
10509
10510    # Find one or more connected partitions in whole topology.
10511
332
398
    for my $obj (@zones, @path_routers) {
10512
1366
3365
        next if $obj->{main} or $obj->{loop};
10513
10514        # Take an arbitrary obj from @zones, name it "zone1".
10515
347
306
        my $zone1 = $obj;
10516
10517        # Starting with zone1, do a traversal of all connected nodes,
10518        # to find a path from every zone and router to zone1.
10519        # Second  parameter is used as placeholder for a not existing
10520        # starting interface.
10521        # Value must be "false" and unequal to any interface.
10522        # Third parameter is distance from $zone1 to $zone1.
10523
347
506
        my $max = setpath_obj($zone1, '', $start_distance);
10524
347
456
        $start_distance = $max + 1;
10525    }
10526
10527
332
430
    for my $obj (@zones, @path_routers) {
10528
1366
2236
        my $loop = $obj->{loop} or next;
10529
10530        # Check all zones and routers located inside a cyclic
10531        # graph. Propagate loop exit into sub-loops.
10532
255
404
        while (my $next = $loop->{redirect}) {
10533
10534#           debug("Redirect: $loop->{exit}->{name} -> $next->{exit}->{name}");
10535
44
76
            $loop = $next;
10536        }
10537
255
224
        $obj->{loop} = $loop;
10538
10539        # Mark connected loops with cluster exit.
10540
255
283
        set_loop_cluster($loop);
10541
10542        # Set distance of loop objects to value of cluster exit.
10543
255
336
        $obj->{distance} = $loop->{cluster_exit}->{distance};
10544    }
10545
332
387
    for my $router (@path_routers) {
10546
484
484
384
601
        for my $interface (@{ $router->{interfaces} }) {
10547
1138
2070
            if (my $loop = $interface->{loop}) {
10548
316
464
                while (my $next = $loop->{redirect}) {
10549
152
213
                    $loop = $next;
10550                }
10551
316
447
                $interface->{loop} = $loop;
10552            }
10553        }
10554    }
10555
10556    # This is called here and not at link_topology because it needs
10557    # attribute {loop}.
10558
332
533
    check_pathrestrictions();
10559
332
419
    check_virtual_interfaces();
10560
332
418
    optimize_pathrestrictions();
10561
332
361
    return;
10562}
10563
10564####################################################################
10565# Efficient path traversal.
10566####################################################################
10567
10568my %obj2path;
10569
10570sub get_path {
10571
1147
0
929
    my ($obj) = @_;
10572
1147
1051
    my $type = ref $obj;
10573
1147
789
    my $result;
10574
1147
2338
    if ($type eq 'Network') {
10575
435
441
        $result = $obj->{zone};
10576    }
10577    elsif ($type eq 'Subnet') {
10578
71
87
        $result = $obj->{network}->{zone};
10579    }
10580    elsif ($type eq 'Interface') {
10581
192
180
        my $router = $obj->{router};
10582
192
440
        if ($router->{managed} || $router->{semi_managed}) {
10583
10584            # If this is a secondary interface, we can't use it to enter
10585            # the router, because it has an active pathrestriction attached.
10586            # But it doesn't matter if we use the main interface instead.
10587
131
278
            $obj = $obj->{main_interface} || $obj;
10588
10589            # Special handling needed if $src or $dst is interface
10590            # which has pathrestriction attached.
10591
131
378
            if ($obj->{path_restrict} || $obj->{reachable_at}) {
10592
40
41
                $result = $obj;
10593            }
10594            else {
10595
91
106
                $result = $obj->{router};
10596            }
10597        }
10598        else {
10599
61
80
            $result = $obj->{network}->{zone};
10600        }
10601    }
10602
10603    # This is used, if called from path_auto_interfaces.
10604    elsif ($type eq 'Router') {
10605
18
53
        if ($obj->{managed} || $obj->{semi_managed}) {
10606
9
11
            $result = $obj;
10607        }
10608        else {
10609
9
13
            $result = $obj->{interfaces}->[0]->{network}->{zone};
10610        }
10611    }
10612
10613    # This is used, if path_walk is called from find_active_routes.
10614    elsif ($type eq 'Zone') {
10615
426
367
        $result = $obj;
10616    }
10617
10618    # This is used, if expand_services without convert_hosts.
10619    elsif ($type eq 'Host') {
10620
5
8
        $result = $obj->{network}->{zone};
10621    }
10622    else {
10623
0
0
        internal_err("unexpected $obj->{name}");
10624    }
10625
10626#    debug("get_path: $obj->{name} -> $result->{name}");
10627
1147
3103
    return($obj2path{$obj} = $result);
10628}
10629
10630# Converts hash key of reference back to reference.
10631my %key2obj;
10632
10633sub cluster_path_mark1;
10634
10635sub cluster_path_mark1 {
10636
321
0
336
    my ($obj, $in_intf, $end, $end_intf, $path_tuples, $loop_leave, $navi) = @_;
10637
321
256
    my $pathrestriction = $in_intf->{path_restrict};
10638
321
252
    my $reachable_at    = $in_intf->{reachable_at};
10639
10640#    debug("cluster_path_mark1: obj: $obj->{name},
10641#           in_intf: $in_intf->{name} to: $end->{name}");
10642
10643    # Check for second occurrence of path restriction.
10644
321
426
    if ($pathrestriction) {
10645
53
57
        for my $restrict (@$pathrestriction) {
10646
40
75
            if ($restrict->{active_path}) {
10647
10648#           debug(" effective $restrict->{name} at $in_intf->{name}");
10649
19
54
                return 0;
10650            }
10651        }
10652    }
10653
10654    # Handle optimized pathrestriction.
10655    # Check if $end_intf is located outside of current reachable_part.
10656    # This must be checked before checking that $end has been reached,
10657
302
731
    if ($reachable_at && $end_intf && $end_intf ne $in_intf) {
10658
28
56
        if (my $reachable = $reachable_at->{$obj}) {
10659
28
24
            my $other = $end_intf->{zone};
10660
10661            # $other inside loop
10662
28
41
            if ($other->{loop}) {
10663
27
22
                my $has_mark = $other->{reachable_part};
10664
27
31
                for my $mark (@$reachable) {
10665
27
62
                    if (!$has_mark->{$mark}) {
10666#                        debug(" unreachable: $other->{name}",
10667#                              " from $in_intf->{name} to $obj->{name}");
10668
10
33
                        return 0;
10669                    }
10670                }
10671            }
10672
10673            # $end_intf at border of loop, $other outside of loop.
10674            # In this case, {reachable_part} isn't set at $other.
10675            # If partition starting at $in_intf also starts at $end_intf,
10676            # then $other can't be reached.
10677            else {
10678
1
3
                if (my $reachable_at2 = $end_intf->{reachable_at}) {
10679
0
0
                    if (my $reachable2 = $reachable_at2->{$end_intf->{router}}) {
10680
0
0
                        if (intersect($reachable, $reachable2)) {
10681#                            debug(" unreachable2: $other->{name}",
10682#                                  " from $in_intf->{name} to $obj->{name}");
10683
0
0
                            return 0;
10684                        }
10685                    }                            
10686                }
10687            }
10688        }
10689    }
10690
10691    # Don't walk loops.
10692
292
409
    if ($obj->{active_path}) {
10693
10694#       debug(" active: $obj->{name}");
10695
2
5
        return 0;
10696    }
10697
10698    # Found a path to router or zone.
10699
290
517
    if ($obj eq $end) {
10700
10701        # Mark interface where we leave the loop.
10702
116
121
        push @$loop_leave, $in_intf;
10703
10704#        debug(" leave: $in_intf->{name} -> $end->{name}");
10705
116
244
        return 1;
10706    }
10707
10708    # Handle optimized pathrestriction.
10709
174
234
    if ($reachable_at) {
10710
73
133
        if (my $reachable = $reachable_at->{$obj}) {
10711
70
87
            my $end_node = $end_intf ? $end_intf->{zone} : $end;
10712
70
58
            my $has_mark = $end_node->{reachable_part};
10713
70
74
            for my $mark (@$reachable) {
10714
70
136
                if (!$has_mark->{$mark}) {
10715#                   debug(" unreachable3: $end_node->{name}",
10716#                         " from $in_intf->{name} to $obj->{name}");
10717
34
104
                    return 0;
10718                }
10719            }
10720        }
10721    }
10722
10723    # Mark current path for loop detection.
10724
140
180
    local $obj->{active_path} = 1;
10725#    debug "activated $obj->{name}";
10726
10727    # Mark first occurrence of path restriction.
10728
140
184
    if ($pathrestriction) {
10729
13
14
        for my $restrict (@$pathrestriction) {
10730
10731#           debug(" enabled $restrict->{name} at $in_intf->{name}");
10732
13
19
            $restrict->{active_path} = 1;
10733        }
10734    }
10735
10736
140
167
    my $get_next = is_router($obj) ? 'zone' : 'router';
10737
140
131
    my $success = 0;
10738
10739    # Fill hash for restoring reference from hash key.
10740
140
188
    $key2obj{$in_intf} = $in_intf;
10741
140
180
    my $allowed = $navi->{ $obj->{loop} };
10742
140
140
115
179
    for my $interface (@{ $obj->{interfaces} }) {
10743
386
717
        next if $interface eq $in_intf;
10744
10745        # As optimization, ignore secondary interface early.
10746
246
376
        next if $interface->{main_interface};
10747
188
157
        my $loop = $interface->{loop};
10748
188
300
        $allowed or internal_err("Loop with empty navigation");
10749
188
481
        next if not $loop or not $allowed->{$loop};
10750
172
167
        my $next = $interface->{$get_next};
10751#        debug "Try $obj->{name} -> $next->{name}";
10752
172
310
        if (
10753            cluster_path_mark1(
10754                $next, $interface, $end, $end_intf,
10755                $path_tuples, $loop_leave, $navi
10756            )
10757          )
10758        {
10759
10760            # Found a valid path from $next to $end.
10761
119
148
            $key2obj{$interface} = $interface;
10762
119
144
            $path_tuples->{$in_intf}->{$interface} = is_router($obj);
10763
10764#           debug(" loop: $in_intf->{name} -> $interface->{name}");
10765
119
214
            $success = 1;
10766        }
10767    }
10768#    debug "deactivated $obj->{name}";
10769
140
205
    if ($pathrestriction) {
10770
13
13
        for my $restrict (@$pathrestriction) {
10771
10772#           debug(" disabled $restrict->{name} at $in_intf->{name}");
10773
13
19
            $restrict->{active_path} = undef;
10774        }
10775    }
10776
140
347
    return $success;
10777}
10778
10779# Optimize navigation inside a cluster of loops.
10780# Mark each loop marker
10781# with the allowed loops to be traversed to reach $to.
10782# The direction is given as a loop object.
10783# It can be used to look up interfaces which reference
10784# this loop object in attribute {loop}.
10785# Return value:
10786# A hash with pairs: object -> loop-marker
10787sub cluster_navigation {
10788
75
0
73
    my ($from, $to) = @_;
10789
75
71
    my $from_loop = $from->{loop};
10790
75
63
    my $to_loop   = $to->{loop};
10791
10792#    debug("Navi: $from->{name}, $to->{name}");
10793
10794
75
63
    my $navi;
10795
75
182
    if (($navi = $from->{navi}->{$to}) and scalar keys %$navi) {
10796
10797#       debug(" Cached");
10798
3
8
        return $navi;
10799    }
10800
72
139
    $navi = $from->{navi}->{$to} = {};
10801
10802
72
68
    while (1) {
10803
135
272
        if ($from_loop eq $to_loop) {
10804
72
158
            last if $from eq $to;
10805
11
23
            $navi->{$from_loop}->{$from_loop} = 1;
10806
10807#           debug("- Eq: $from_loop->{exit}->{name}$from_loop to itself");
10808
10809            # Path $from -> $to traverses $from_loop and $exit_loop.
10810            # Inside $exit_loop, enter only $from_loop, but not from other loops.
10811
11
13
            my $exit_loop = $from_loop->{exit}->{loop};
10812
11
20
            $navi->{$exit_loop}->{$from_loop} = 1;
10813
10814#           debug("- Add $from_loop->{exit}->{name}$from_loop to exit $exit_loop->{exit}->{name}$exit_loop");
10815
11
18
            last;
10816        }
10817        elsif ($from_loop->{distance} >= $to_loop->{distance}) {
10818
18
35
            $navi->{$from_loop}->{$from_loop} = 1;
10819
10820#           debug("- Fr: $from_loop->{exit}->{name}$from_loop to itself");
10821
18
20
            $from      = $from_loop->{exit};
10822
18
22
            $from_loop = $from->{loop};
10823        }
10824        else {
10825
45
99
            $navi->{$to_loop}->{$to_loop} = 1;
10826
10827#           debug("- To: $to_loop->{exit}->{name}$to_loop to itself");
10828
45
53
            $to = $to_loop->{exit};
10829
45
37
            my $entry_loop = $to->{loop};
10830
45
97
            $navi->{$entry_loop}->{$to_loop} = 1;
10831
10832#           debug("- Add $to_loop->{exit}->{name}$to_loop to entry $entry_loop->{exit}->{name}$entry_loop");
10833
45
54
            $to_loop = $entry_loop;
10834        }
10835    }
10836
72
152
    return $navi;
10837}
10838
10839# Mark paths inside a cluster of loops.
10840# $from and $to are entry and exit objects inside the cluster.
10841# The cluster is entered at interface $from_in and left at interface $to_out.
10842# For each pair of $from / $to, we collect attributes:
10843# {loop_enter}: interfaces of $from, where the cluster is entered,
10844# {path_tuples}: tuples of interfaces, which describe all valid paths,
10845# {loop_leave}: interfaces of $to, where the cluster is left.
10846# Return value is true if a valid path was found.
10847#
10848# $from_store is the starting object of the whole path.
10849# If the path starts at an interface of a loop and it has a pathrestriction attached,
10850# $from_store contains this interface.
10851sub cluster_path_mark  {
10852
197
0
205
    my ($from, $to, $from_in, $to_out, $from_store, $to_store) = @_;
10853
10854    # This particular path through this sub-graph is already known.
10855
197
362
    return 1 if $from_in->{path}->{$to_store};
10856
10857    # Start and end interface or undef.
10858    # It is set, if the path starts / ends
10859    # - at an interface inside the loop or
10860    # - at an interface at the border of the loop
10861    #   (an interface of a router/zone inside the loop)
10862    # - this interface has a pathrestriction attached.
10863
197
146
    my ($start_intf, $end_intf);
10864
10865    # Check, if loop is entered or left at interface with pathrestriction.
10866    # - is $from_store located inside or at border of current loop?
10867    # - does $from_in at border of current loop have pathrestriction ?
10868    # dito for $to_store and $to_out.
10869
0
0
    my ($start_store, $end_store);
10870
197
234
    if (is_interface($from_store)
10871        and ($from_store->{router} eq $from or $from_store->{zone} eq $from))
10872    {
10873
37
28
        $start_intf  = $from_store;
10874
37
28
        $start_store = $from_store;
10875    }
10876    elsif ($from_in
10877           and ($from_in->{path_restrict} or $from_in->{reachable_at}))
10878    {
10879
7
7
        $start_store = $from_in;
10880    }
10881    else {
10882
153
131
        $start_store = $from;
10883    }
10884
197
270
    if (is_interface($to_store)
10885        and ($to_store->{router} eq $to or $to_store->{zone} eq $to))
10886    {
10887
48
37
        $end_intf  = $to_store;
10888
48
40
        $end_store = $to_store;
10889    }
10890    elsif ($to_out and ($to_out->{path_restrict} or $to_out->{reachable_at})) {
10891
2
3
        $end_store = $to_out;
10892    }
10893    else {
10894
147
121
        $end_store = $to;
10895    }
10896
10897
197
177
    my $success = 1;
10898
197
171
    my $from_interfaces = $from->{interfaces};
10899
10900#    debug("cluster_path_mark: $start_store->{name} -> $end_store->{name}");
10901
10902    # Activate pathrestriction of interface at border of loop, if path starts
10903    # or ends outside the loop and enters the loop at such an interface.
10904
197
724
    if (    $from_in
10905        and not $from_in->{loop}
10906        and (my $restrictions = $from_in->{path_restrict})
10907        and not $start_intf)
10908    {
10909
7
9
        for my $restrict (@$restrictions) {
10910
7
12
            $restrict->{active_path} = 1;
10911        }
10912    }
10913
197
417
    if (    $to_out
10914        and not $to_out->{loop}
10915        and (my $restrictions = $to_out->{path_restrict})
10916        and not $end_intf)
10917    {
10918
2
7
        for my $restrict (@$restrictions) {
10919
2
6
            if ($restrict->{active_path}) {
10920
10921                # Pathrestriction is applied to both, incoming and outgoing interface.
10922                # This prevents traffic through loop.
10923
0
0
                $success = 0;
10924            }
10925
2
4
            $restrict->{active_path} = 1;
10926        }
10927    }
10928
10929    # Check optimized pathrestriction for path starting inside or
10930    # outside the loop.
10931  REACHABLE:
10932    {
10933
10934        # Check if end node is reachable.
10935        # Interface with pathrestriction belongs to zone.
10936
197
197
141
253
        my $end_node = $end_intf ? $end_intf->{zone} : $to;
10937
10938        # $start_intf is directly connected to $end_node.
10939        # This must be handled as special case, because
10940        # optimized pathrestriction doesn't prevent path through router.
10941        # Ignore all interfaces except direction to zone.
10942
197
380
        if ($start_intf && $start_intf->{zone} eq $end_node) {
10943
11
14
            $from_interfaces = [ $start_intf ];
10944
11
14
            last REACHABLE;
10945        }
10946
10947        # If path starts at interface of loop, then ignore restriction
10948        # in direction to zone, hence check only the router.
10949
186
204
        my $start_node = $start_intf ? $start_intf->{router} : $from;
10950
186
387
        my $intf = $start_intf || $from_in;
10951
186
379
        my $reachable_at = $intf->{reachable_at} or last REACHABLE;            
10952
7
13
        my $reachable = $reachable_at->{$start_node} or last REACHABLE;
10953
7
6
        my $has_mark = $end_node->{reachable_part};
10954
7
9
        for my $mark (@$reachable) {
10955
7
11
            if (!$has_mark->{$mark}) {
10956
4
5
                if ($start_intf) {
10957
10958                    # Ignore all interfaces except direction to zone
10959
4
5
                    $from_interfaces = [ $start_intf ];
10960                }
10961                else {
10962
0
0
                    $success = 0;
10963                }
10964
4
6
                last;
10965            }
10966        }
10967
7
21
        if ($success && $start_intf) {
10968
10969            # Temporarily disable optimized pathrestriction in
10970            # direction to zone.
10971
7
7
            my $zone = $start_intf->{zone};
10972
7
19
            $intf->{saved_reachable_at_zone} = delete $reachable_at->{$zone};
10973        }
10974    }
10975
10976    # If start / end interface is part of a group of virtual
10977    # interfaces (VRRP, HSRP),
10978    # prevent traffic through other interfaces of this group.
10979
197
209
    for my $intf ($start_intf, $end_intf) {
10980
394
615
        next if !$intf;
10981
85
156
        if (my $interfaces = $intf->{redundancy_interfaces}) {
10982
25
24
            for my $interface (@$interfaces) {
10983
50
102
                next if $interface eq $intf;
10984
25
25
20
60
                push @{ $interface->{path_restrict} },
10985                  $global_active_pathrestriction;
10986            }
10987        }
10988    }
10989
10990    # Handle special case where path starts or ends at an interface
10991    # with pathrestriction.
10992    # If the router is left / entered via the same interface, ignore
10993    # the PR.  If the router is left / entered via some other
10994    # interface, add the PR of the start- / end interface to the other
10995    # interface.
10996
197
210
    for my $intf ($start_intf, $end_intf) {
10997
394
580
        next if !$intf;
10998
85
72
        my $router = $intf->{router};
10999
85
275
        next if !($router eq $from || $router eq $to);
11000
83
186
        my $removed = delete $intf->{path_restrict} or next;
11001
45
48
        $intf->{saved_path_restrict} = $removed;
11002
45
45
37
59
        for my $interface (@{ $router->{interfaces} }) {
11003
161
295
            next if $interface eq $intf;
11004
116
122
            my $orig =
11005                $interface->{saved_path_restrict} =
11006                $interface->{path_restrict};
11007
116
121
            if ($orig) {
11008
3
6
                if (intersect($orig, $removed)) {
11009
3
11
                    $interface->{path_restrict} =
11010                        [ $global_active_pathrestriction ];
11011                }
11012                else {
11013
0
0
                    $interface->{path_restrict} = [ @$orig, @$removed ];
11014                }
11015            }
11016            else {
11017
113
161
                $interface->{path_restrict} = $removed;
11018            }
11019        }
11020    }
11021
11022  BLOCK:
11023    {
11024
197
197
178
267
        last BLOCK if not $success;
11025
197
152
        $success = 0;
11026
11027
197
325
        $from_in->{loop_entry}->{$to_store}    = $start_store;
11028
197
279
        $start_store->{loop_exit}->{$to_store} = $end_store;
11029
11030        # Path from $start_store to $end_store inside cyclic graph
11031        # has been marked already.
11032
197
383
        if ($start_store->{loop_enter}->{$end_store}) {
11033
122
92
            $success = 1;
11034
122
134
            last BLOCK;
11035        }
11036
11037
75
84
        my $loop_enter  = [];
11038
75
83
        my $path_tuples = {};
11039
75
70
        my $loop_leave  = [];
11040
11041
75
104
        my $navi = cluster_navigation($from, $to)
11042          or internal_err("Empty navi");
11043
11044#       use Dumpvalue;
11045#       Dumpvalue->new->dumpValue($navi);
11046
11047        # Mark current path for loop detection.
11048
75
120
        local $from->{active_path} = 1;
11049
75
97
        my $get_next = is_router($from) ? 'zone' : 'router';
11050
75
171
        my $allowed = $navi->{ $from->{loop} }
11051          or internal_err("Loop $from->{loop}->{exit}->{name}$from->{loop}",
11052            " with empty navi");
11053
75
91
        for my $interface (@$from_interfaces) {
11054
220
340
            next if $interface->{main_interface};
11055
184
156
            my $loop = $interface->{loop};
11056
184
270
            next if not $loop;
11057
151
266
            if (not $allowed->{$loop}) {
11058
11059#               debug("No: $loop->{exit}->{name}$loop");
11060
2
3
                next;
11061            }
11062
11063            # Don't enter network which connects pair of virtual loopback
11064            # interfaces.
11065
149
248
            next if $interface->{loopback} and $get_next eq 'zone';
11066
149
145
            my $next = $interface->{$get_next};
11067
11068#           debug(" try: $from->{name} -> $interface->{name}");
11069
149
196
            if (
11070                cluster_path_mark1(
11071                    $next, $interface, $to, $end_intf,
11072                    $path_tuples, $loop_leave, $navi
11073                )
11074              )
11075            {
11076
114
87
                $success = 1;
11077
114
172
                push @$loop_enter, $interface;
11078
11079#               debug(" enter: $from->{name} -> $interface->{name}");
11080            }
11081        }
11082
11083        # Don't store incomplete result.
11084
75
122
        last BLOCK if not $success;
11085
11086        # Convert { intf->intf->node_type } to [ intf, intf, node_type ]
11087
73
78
        my $tuples_aref = [];
11088
73
145
        for my $in_intf_ref (keys %$path_tuples) {
11089
115
171
            my $in_intf = $key2obj{$in_intf_ref}
11090              or internal_err("Unknown in_intf at tuple");
11091
115
105
            my $hash = $path_tuples->{$in_intf_ref};
11092
115
162
            for my $out_intf_ref (keys %$hash) {
11093
119
180
                my $out_intf = $key2obj{$out_intf_ref}
11094                  or internal_err("Unknown out_intf at tuple");
11095
119
113
                my $at_router = $hash->{$out_intf_ref};
11096
119
344
                push @$tuples_aref, [ $in_intf, $out_intf, $at_router ];
11097
11098#               debug("Tuple: $in_intf->{name}, $out_intf->{name} $at_router");
11099            }
11100        }
11101
11102        # Remove duplicates, which occur from nested loops..
11103
73
116
        $loop_leave = [ unique(@$loop_leave) ];
11104
11105
73
137
        $start_store->{loop_enter}->{$end_store}  = $loop_enter;
11106
73
125
        $start_store->{loop_leave}->{$end_store}  = $loop_leave;
11107
73
111
        $start_store->{path_tuples}->{$end_store} = $tuples_aref;
11108
11109        # Add data for reverse path.
11110
73
116
        $end_store->{loop_enter}->{$start_store} = $loop_leave;
11111
73
110
        $end_store->{loop_leave}->{$start_store} = $loop_enter;
11112
119
431
        $end_store->{path_tuples}->{$start_store} =
11113
73
119
148
96
          [ map { [ @{$_}[ 1, 0, 2 ] ] } @$tuples_aref ];
11114    }
11115
11116    # Restore temporarily changed path restrictions.
11117
197
223
    for my $intf ($start_intf, $end_intf) {
11118
394
614
        next if !$intf;
11119
85
141
        next if !$intf->{saved_path_restrict};
11120
45
41
        my $router = $intf->{router};
11121
45
45
37
56
        for my $interface (@{ $router->{interfaces} }) {
11122
161
216
            if (my $orig = delete $interface->{saved_path_restrict}) {
11123
48
79
                $interface->{path_restrict} = $orig ;
11124            }
11125            else {
11126
113
148
                delete $interface->{path_restrict};
11127            }
11128        }
11129    }
11130
197
286
    if ($start_intf) {
11131
37
69
        if (my $orig = delete $start_intf->{saved_reachable_at_zone}) {
11132
7
7
            my $zone = $start_intf->{zone};
11133
7
15
            $start_intf->{reachable_at}->{$zone} = $orig;
11134        }
11135    }
11136
197
187
    for my $intf ($start_intf, $end_intf) {
11137
394
569
        next if !$intf;
11138
85
149
        if (my $interfaces = $intf->{redundancy_interfaces}) {
11139
25
25
            for my $interface (@$interfaces) {
11140
50
103
                next if $interface eq $intf;
11141
25
25
18
49
                pop @{ $interface->{path_restrict} };
11142            }
11143        }
11144    }
11145
11146    # Disable pathrestriction at border of loop.
11147
197
197
    for my $intf ($from_in, $to_out) {
11148
394
1212
        if (    $intf
11149            and not $intf->{loop}
11150            and (my $restrictions = $intf->{path_restrict}))
11151        {
11152
11
11
            for my $restrict (@$restrictions) {
11153
13
24
                $restrict->{active_path} = 0;
11154            }
11155        }
11156    }
11157
197
296
    if ($success) {
11158
11159        # When entering sub-graph at $from_in we will leave it at $to_out.
11160
195
314
        $from_in->{path}->{$to_store} = $to_out;
11161    }
11162
197
572
    return $success;
11163}
11164
11165# Mark path from $from to $to.
11166# $from and $to are either a router or a zone.
11167# For a path without loops, $from_store equals $from and $to_store equals $to.
11168# If the path starts at an interface inside a cluster of loops
11169# or at the border of a cluster,
11170# and the interface has a pathrestriction attached,
11171# then $from_store contains this interface.
11172# If the path ends at an interface inside a loop or at the border of a loop,
11173# $to_store contains this interface.
11174# At each interface on the path from $from to $to,
11175# we place a reference to the next interface on the path to $to_store.
11176# This reference is found in a hash at attribute {path}.
11177# Additionally we attach the path attribute to the src object.
11178# Return value is true if a valid path was found.
11179sub path_mark {
11180
519
0
540
    my ($from, $to, $from_store, $to_store) = @_;
11181
11182#    debug("path_mark $from_store->{name} --> $to_store->{name}");
11183
11184
519
464
    my $from_loop = $from->{loop};
11185
519
474
    my $to_loop   = $to->{loop};
11186
11187    # $from_store and $from differ if path starts at an interface
11188    # with pathrestriction.
11189    # Inside a loop, use $from_store, not $from,
11190    # because the path may differ depending on the start interface.
11191    # But outside a loop (pathrestriction is allowed at the border of a loop)
11192    # we have only a single path which enters the loop.
11193    # In this case we must not use the interface but the router,
11194    # otherwise we would get an invalid {path}:
11195    # $from_store->{path}->{$to_store} = $from_store;
11196
519
644
    my $from_in = $from_store->{loop} ? $from_store : $from;
11197
519
399
    my $to_out = undef;
11198
519
394
    while (1) {
11199
11200#        debug("Dist: $from->{distance} $from->{name} ->Dist: $to->{distance} $to->{name}");
11201        # Paths meet outside a loop or at the edge of a loop.
11202
1356
2314
        if ($from eq $to) {
11203
11204#            debug(" $from_in->{name} -> ".($to_out ? $to_out->{name}:''));
11205
326
464
            $from_in->{path}->{$to_store} = $to_out;
11206
326
760
            return 1;
11207        }
11208
11209        # Paths meet inside a loop.
11210
1030
2235
        if (   $from_loop
11211            && $to_loop
11212            && $from_loop->{cluster_exit} eq $to_loop->{cluster_exit})
11213        {
11214
184
250
            return cluster_path_mark($from, $to, $from_in, $to_out, $from_store,
11215                $to_store);
11216        }
11217
11218
846
1175
        if ($from->{distance} >= $to->{distance}) {
11219
11220            # Mark has already been set for a sub-path.
11221
365
676
            return 1 if $from_in->{path}->{$to_store};
11222
358
318
            my $from_out = $from->{main};
11223
358
487
            unless ($from_out) {
11224
11225                # Reached border of partition.
11226
7
18
                return 0 if !$from_loop;
11227
11228                # $from_loop references object which is loop's exit.
11229
7
7
                my $exit = $from_loop->{cluster_exit};
11230
7
7
                $from_out = $exit->{main};
11231
11232                # Reached border of partition.
11233
7
11
                return 0 if !$from_out;
11234
11235
7
11
                cluster_path_mark($from, $exit, $from_in, $from_out,
11236                    $from_store, $to_store)
11237                  or return 0;
11238            }
11239
11240#            debug(" $from_in->{name} -> ".($from_out ? $from_out->{name}:''));
11241
358
529
            $from_in->{path}->{$to_store} = $from_out;
11242
358
284
            $from_in                      = $from_out;
11243
358
308
            $from                         = $from_out->{main};
11244
358
425
            $from_loop                    = $from->{loop};
11245        }
11246        else {
11247
481
405
            my $to_in = $to->{main};
11248
481
670
            unless ($to_in) {
11249
11250                # Reached border of partition.
11251
8
16
                return 0 if !$to_loop;
11252
11253
6
8
                my $entry = $to_loop->{cluster_exit};
11254
6
6
                $to_in = $entry->{main};
11255
11256                # Reached border of partition.
11257
6
8
                return 0 if !$to_in;
11258
11259
6
9
                cluster_path_mark($entry, $to, $to_in, $to_out, $from_store,
11260                    $to_store)
11261                  or return 0;
11262            }
11263
11264#            debug(" $to_in->{name} -> ".($to_out ? $to_out->{name}:''));
11265
479
753
            $to_in->{path}->{$to_store} = $to_out;
11266
479
359
            $to_out                     = $to_in;
11267
479
406
            $to                         = $to_in->{main};
11268
479
525
            $to_loop                    = $to->{loop};
11269        }
11270    }
11271
0
0
    return 0; # unused; only for perlcritic
11272}
11273
11274# Walk paths inside cyclic graph
11275sub loop_path_walk {
11276
271
0
352
    my ($in, $out, $loop_entry, $loop_exit, $call_at_zone, $rule, $fun) = @_;
11277
11278#    my $info = "loop_path_walk: ";
11279#    $info .= "$in->{name}->" if $in;
11280#    $info .= "$loop_entry->{name}=>$loop_exit->{name}";
11281#    $info .= "->$out->{name}" if $out;
11282#    debug($info);
11283
11284    # Process entry of cyclic graph.
11285
271
298
    if (
11286        (
11287            is_router($loop_entry)
11288            or
11289
11290            # $loop_entry is interface with pathrestriction of original
11291            # loop_entry.
11292            is_interface($loop_entry)
11293            and
11294
11295            # Take only interface which originally was a router.
11296            $loop_entry->{router} eq
11297            $loop_entry->{loop_enter}->{$loop_exit}->[0]->{router}
11298        ) xor $call_at_zone
11299      )
11300    {
11301
11302#     debug(" loop_enter");
11303
105
105
85
198
        for my $out_intf (@{ $loop_entry->{loop_enter}->{$loop_exit} }) {
11304
155
200
            $fun->($rule, $in, $out_intf);
11305        }
11306    }
11307
11308    # Process paths inside cyclic graph.
11309
271
445
    my $path_tuples = $loop_entry->{path_tuples}->{$loop_exit};
11310
11311#    debug(" loop_tuples");
11312
271
305
    for my $tuple (@$path_tuples) {
11313
406
403
        my ($in_intf, $out_intf, $at_router) = @$tuple;
11314
406
1312
        $fun->($rule, $in_intf, $out_intf)
11315          if $at_router xor $call_at_zone;
11316    }
11317
11318    # Process paths at exit of cyclic graph.
11319
271
340
    my $exit_at_router =
11320          is_router($loop_exit)
11321       || (is_interface($loop_exit)
11322           && $loop_exit->{router} eq
11323           $loop_entry->{loop_leave}->{$loop_exit}->[0]->{router});
11324
271
804
    if ($exit_at_router xor $call_at_zone) {
11325
11326#     debug(" loop_leave");
11327
165
165
125
307
        for my $in_intf (@{ $loop_entry->{loop_leave}->{$loop_exit} }) {
11328
243
286
            $fun->($rule, $in_intf, $out);
11329        }
11330    }
11331
271
466
    return $exit_at_router;
11332}
11333
11334# Apply a function to a rule at every router or zone on the path from
11335# src to dst of the rule.
11336# $where tells, where the function gets called: at 'Router' or 'Zone'.
11337# Default is 'Router'.
11338sub path_walk {
11339
1467
0
1452
    my ($rule, $fun, $where) = @_;
11340
1467
2096
    internal_err("undefined rule") unless $rule;
11341
1467
1285
    my $src = $rule->{src};
11342
1467
1211
    my $dst = $rule->{dst};
11343
11344
1467
3091
    my $from_store = $obj2path{$src}       || get_path $src;
11345
1467
2857
    my $to_store   = $obj2path{$dst}       || get_path $dst;
11346
1467
3466
    my $from       = $from_store->{router} || $from_store;
11347
1467
3168
    my $to         = $to_store->{router}   || $to_store;
11348
1467
1788
    my $path_store = $from_store->{loop} ? $from_store : $from;
11349
11350#    debug(print_rule $rule);
11351#    debug(" start: $from->{name}, $to->{name}" . ($where?", at $where":''));
11352#    my $fun2 = $fun;
11353#    $fun = sub  {
11354#       my($rule, $in, $out) = @_;
11355#       my $in_name = $in?$in->{name}:'-';
11356#       my $out_name = $out?$out->{name}:'-';
11357#       debug(" Walk: $in_name, $out_name");
11358#       $fun2->(@_);
11359#    };
11360
1467
4090
    $from and $to or internal_err(print_rule $rule);
11361
1467
2626
    $from eq $to and internal_err("Unenforceable:\n ", print_rule $rule);
11362
11363
1467
2753
    if (!$path_store->{path}->{$to_store}) {
11364
495
704
        if (!path_mark($from, $to, $from_store, $to_store)) {
11365
4
13
            err_msg("No valid path\n",
11366                    " from $from_store->{name}\n",
11367                    " to $to_store->{name}\n",
11368                    " for rule ", print_rule($rule), "\n",
11369                    " Check path restrictions and crypto interfaces.");
11370
4
10
            delete $path_store->{path}->{$to_store};
11371
4
12
            return;
11372        }
11373    }
11374
1463
1170
    my $in = undef;
11375
1463
1054
    my $out;
11376
1463
3018
    my $at_zone = $where && $where eq 'Zone';
11377
1463
1730
    my $call_it = (is_router($from) xor $at_zone);
11378
11379    # Path starts inside a cyclic graph
11380    # or at interface of router inside cyclic graph.
11381
1463
3919
    if ($from->{loop}
11382        and $from_store->{loop_exit}
11383        and my $loop_exit = $from_store->{loop_exit}->{$to_store})
11384    {
11385
201
259
        my $loop_out = $path_store->{path}->{$to_store};
11386
201
239
        my $exit_at_router =
11387            loop_path_walk($in, $loop_out, $from_store, $loop_exit, $at_zone,
11388                           $rule, $fun);
11389
201
302
        if (not $loop_out) {
11390
11391#           debug("exit: path_walk: dst in loop");
11392
143
343
            return;
11393        }
11394
11395        # Continue behind loop.
11396
58
151
        $call_it = not($exit_at_router xor $at_zone);
11397
58
46
        $in      = $loop_out;
11398
58
102
        $out     = $in->{path}->{$to_store};
11399    }
11400    else {
11401
1262
1882
        $out = $path_store->{path}->{$to_store};
11402    }
11403
1320
977
    while (1) {
11404
4411
12403
        if (    $in
11405            and $in->{loop_entry}
11406            and my $loop_entry = $in->{loop_entry}->{$to_store})
11407        {
11408
70
92
            my $loop_exit = $loop_entry->{loop_exit}->{$to_store};
11409
70
83
            my $loop_out  = $in->{path}->{$to_store};
11410
70
88
            my $exit_at_router =
11411                loop_path_walk($in, $loop_out, $loop_entry, $loop_exit,
11412                               $at_zone, $rule, $fun);
11413
70
95
            if (not $loop_out) {
11414
11415#               debug("exit: path_walk: reached dst in loop");
11416
52
126
                return;
11417            }
11418
18
50
            $call_it = not($exit_at_router xor $at_zone);
11419
18
15
            $in      = $loop_out;
11420
18
34
            $out     = $in->{path}->{$to_store};
11421        }
11422        else {
11423
4341
5567
            if ($call_it) {
11424
1858
2290
                $fun->($rule, $in, $out);
11425            }
11426
11427            # End of path has been reached.
11428
4341
5602
            if (not $out) {
11429
11430#               debug("exit: path_walk: reached dst");
11431
1268
2871
                return;
11432            }
11433
3073
2736
            $call_it = !$call_it;
11434
3073
2266
            $in      = $out;
11435
3073
4418
            $out     = $in->{path}->{$to_store};
11436        }
11437    }
11438
0
0
    return;
11439}
11440
11441my %border2obj2auto;
11442
11443sub set_auto_intf_from_border  {
11444
10
0
11
    my ($border) = @_;
11445
10
7
    my %active_path;
11446    my $reach_from_border;
11447    $reach_from_border = sub {
11448
74
67
        my ($network, $in_intf, $result) = @_;
11449
74
86
        $active_path{$network} = 1;
11450
74
123
        $result->{$network}->{$in_intf} = $in_intf;
11451#        debug "$network->{name}: $in_intf->{name}";
11452
74
74
47
92
        for my $interface (@{ $network->{interfaces} }) {
11453
153
282
            next if $interface eq $in_intf;
11454
79
101
            next if $interface->{zone};
11455
73
110
            next if $interface->{orig_main};
11456
61
43
            my $router = $interface->{router};
11457
61
115
            next if $active_path{$router};
11458
39
43
            $active_path{$router} = 1;
11459
39
62
            $result->{$router}->{$interface} = $interface;
11460#            debug "$router->{name}: $interface->{name}";
11461
11462
39
39
27
62
            for my $out_intf (@{ $router->{interfaces} }) {
11463
115
202
                next if $out_intf eq $interface;
11464
76
99
                next if $out_intf->{orig_main};
11465
64
60
                my $out_net = $out_intf->{network};
11466
64
81
                $reach_from_border->($out_net, $out_intf, $result);
11467            }
11468
39
68
            $active_path{$router} = 0;
11469        }
11470
74
141
        $active_path{$network} = 0;
11471
10
37
    };
11472
10
14
    my $result = {};
11473
10
14
    $reach_from_border->($border->{network}, $border, $result);
11474
10
20
    for my $href (values %$result) {
11475
42
90
        $href = [ values %$href ];
11476    }
11477
10
17
    $border2obj2auto{$border} = $result;
11478
10
16
    return;
11479}
11480
11481# $src is an auto_interface, interface or router.
11482# Result is the set of interfaces of $src located at the front side
11483# of the direction to $dst.
11484sub path_auto_interfaces {
11485
55
0
55
    my ($src, $dst) = @_;
11486
55
37
    my @result;
11487
52
74
    my ($src2, $managed) =
11488      is_autointerface($src)
11489
55
66
      ? @{$src}{ 'object', 'managed' }
11490      : ($src, undef);
11491
55
70
    my $dst2 = is_autointerface($dst) ? $dst->{object} : $dst;
11492
11493
55
153
    my $from_store = $obj2path{$src2}      || get_path $src2;
11494
55
125
    my $to_store   = $obj2path{$dst2}      || get_path $dst2;
11495
55
149
    my $from       = $from_store->{router} || $from_store;
11496
55
131
    my $to         = $to_store->{router}   || $to_store;
11497
11498
55
105
    $from eq $to and return ();
11499
53
106
    if (!$from_store->{path}->{$to_store}) {
11500
24
37
        if (!path_mark($from, $to, $from_store, $to_store)) {
11501
0
0
            err_msg("No valid path\n",
11502                    " from $from_store->{name}\n",
11503                    " to $to_store->{name}\n",
11504                    " while resolving $src->{name}",
11505                    " (destination is $dst->{name}).\n",
11506                    " Check path restrictions and crypto interfaces.");
11507
0
0
            delete $from_store->{path}->{$to_store};
11508
0
0
            return;
11509        }
11510    }
11511
53
122
    if ($from_store->{loop_exit}
11512        and my $exit = $from_store->{loop_exit}->{$to_store})
11513    {
11514
9
9
7
22
        @result = @{ $from->{loop_enter}->{$exit} };
11515    }
11516    else {
11517
44
76
        @result = ($from_store->{path}->{$to_store});
11518    }
11519
53
62
53
129
    @result = grep { $_->{ip} ne 'tunnel' } @result;
11520
11521    # Find auto interface inside zone.
11522    # $src is located inside some zone.
11523    # $src2 is known to be unmanaged router or network.
11524
53
68
    if (!is_router($from)) {
11525
34
26
        my %result;
11526
34
36
        for my $border (@result) {
11527
40
78
            if (not $border2obj2auto{$border}) {
11528
10
14
                set_auto_intf_from_border($border);
11529            }
11530
40
60
            my $auto_intf = $border2obj2auto{$border}->{$src2};
11531
40
41
            for my $interface (@$auto_intf) {
11532
60
128
                $result{$interface} = $interface;
11533            }
11534        }
11535
34
84
        @result = sort by_name values %result;
11536    }
11537
11538
53
50
    my $bridged_count = 0;
11539
53
54
    for my $interface (@result) {
11540
11541        # If device has virtual interface, main and virtual interface
11542        # are swapped.  Swap it back here because we need the
11543        # original main interface if an interface is used in a rule.
11544
80
218
        if (my $orig = $interface->{orig_main}) {
11545
0
0
            $interface = $orig;
11546        }
11547
11548        # Change bridge interface to layer3 interface.
11549        # Prevent duplicate layer3 interface.
11550        elsif (my $layer3_intf = $interface->{layer3_interface}) {
11551
2
2
            $interface = $layer3_intf;
11552
2
3
            $bridged_count++;
11553        }
11554    }
11555
53
84
    if ($bridged_count > 1) {
11556
0
0
        @result = unique(@result);
11557    }
11558
11559#    debug("$src2->{name}.[auto] = ", join ',', map {$_->{name}} @result);
11560
53
0
144
0
    return($managed ? grep { $_->{router}->{managed} } @result : @result);
11561}
11562
11563########################################################################
11564# Handling of crypto tunnels.
11565########################################################################
11566
11567sub link_ipsec  {
11568
337
0
591
    for my $ipsec (values %ipsec) {
11569
11570        # Convert name of ISAKMP definition to object with ISAKMP definition.
11571
20
20
19
34
        my ($type, $name) = @{ $ipsec->{key_exchange} };
11572
20
33
        if ($type eq 'isakmp') {
11573
20
43
            my $isakmp = $isakmp{$name}
11574              or err_msg "Can't resolve reference to $type:$name",
11575              " for $ipsec->{name}";
11576
20
50
            $ipsec->{key_exchange} = $isakmp;
11577        }
11578        else {
11579
0
0
            err_msg("Unknown key_exchange type '$type' for $ipsec->{name}");
11580        }
11581    }
11582
337
313
    return;
11583}
11584
11585sub link_crypto  {
11586
337
0
682
    for my $crypto (values %crypto) {
11587
21
22
        my $name = $crypto->{name};
11588
11589        # Convert name of IPSec definition to object with IPSec definition.
11590
21
21
18
32
        my ($type, $name2) = @{ $crypto->{type} };
11591
11592
21
28
        if ($type eq 'ipsec') {
11593
21
45
            my $ipsec = $ipsec{$name2}
11594              or err_msg "Can't resolve reference to $type:$name2",
11595              " for $name";
11596
21
36
            $crypto->{type} = $ipsec;
11597        }
11598        else {
11599
0
0
            err_msg("Unknown type '$type' for $name");
11600        }
11601    }
11602
337
298
    return;
11603}
11604
11605# Generate rules to permit crypto traffic between tunnel endpoints.
11606sub gen_tunnel_rules  {
11607
27
0
25
    my ($intf1, $intf2, $ipsec) = @_;
11608
27
23
    my $use_ah = $ipsec->{ah};
11609
27
48
    my $use_esp = $ipsec->{esp_authentication} || $ipsec->{esp_encryption};
11610
27
28
    my $nat_traversal = $ipsec->{key_exchange}->{nat_traversal};
11611
27
24
    my @rules;
11612
27
42
    my $rule = { src => $intf1, dst => $intf2 };
11613
27
76
    if (not $nat_traversal or $nat_traversal ne 'on') {
11614
27
33
        $use_ah
11615          and push @rules, { %$rule, prt => $prt_ah };
11616
27
87
        $use_esp
11617          and push @rules, { %$rule, prt => $prt_esp };
11618
27
71
        push @rules,
11619          {
11620            %$rule,
11621            src_range => $prt_ike->{src_range},
11622            prt       => $prt_ike->{dst_range}
11623          };
11624    }
11625
27
45
    if ($nat_traversal) {
11626
15
32
        push @rules,
11627          {
11628            %$rule,
11629            src_range => $prt_natt->{src_range},
11630            prt       => $prt_natt->{dst_range}
11631          };
11632    }
11633
27
62
    return \@rules;
11634}
11635
11636# Link tunnel networks with tunnel hubs.
11637# ToDo: Are tunnels between different private contexts allowed?
11638sub link_tunnels  {
11639
11640
337
0
305
    my %hub_seen;
11641
11642    # Collect clear-text interfaces of all tunnels.
11643    my @real_interfaces;
11644
11645
337
774
    for my $crypto (sort by_name values %crypto) {
11646
21
24
        my $name        = $crypto->{name};
11647
21
22
        my $private     = $crypto->{private};
11648
21
29
        my $real_hubs   = delete $crypto2hubs{$name};
11649
21
32
        my $real_spokes = delete $crypto2spokes{$name};
11650
21
21
29
49
        $real_hubs      = [ grep { !$_->{disabled} } @$real_hubs ];
11651
21
25
24
44
        $real_spokes    = [ grep { !$_->{disabled} } @$real_spokes ];
11652
21
79
        $real_hubs and @$real_hubs
11653          or warn_msg("No hubs have been defined for $name");
11654
11655
21
64
        $real_spokes and @$real_spokes
11656          or warn_msg("No spokes have been defined for $name");
11657
11658
21
25
        my $isakmp = $crypto->{type}->{key_exchange};
11659
21
34
        my $need_id = $isakmp->{authentication} eq 'rsasig';
11660
21
24
        for my $real_hub (@$real_hubs) {
11661
11662            # Substitute crypto name by crypto object.
11663
21
21
13
32
            for my $crypto_name (@{ $real_hub->{hub} }) {
11664
27
63
                $crypto_name eq $name and $crypto_name = $crypto;
11665            }
11666
11667            # Collect managed routers with crypto hub.
11668            # Note: Crypto routers are splitted internally into
11669            # two nodes. Typically we get get a node with only
11670            # a single crypto interface.
11671
21
22
            my $router = $real_hub->{router};
11672
21
32
            $router->{managed} or next;
11673
11674            # Router of type {do_auth} can only check certificates,
11675            # not pre-shared keys.
11676
21
59
            $router->{model}->{do_auth} and not $need_id and
11677                err_msg("$router->{name} needs authentication=rsasig",
11678                        " in $isakmp->{name}");
11679
11680            # Take original router with cleartext interface(s).
11681
21
32
            if (my $orig_router = $router->{orig_router}) {
11682
18
19
                $router = $orig_router;
11683            }
11684
21
77
            push @managed_crypto_hubs, $router if not $hub_seen{$router}++;
11685        }
11686
21
22
        push @real_interfaces, @$real_hubs;
11687
11688        # Generate a single tunnel from each spoke to a single hub.
11689        # If there are multiple hubs, they are assumed to form
11690        # a high availability cluster. In this case a single tunnel is created
11691        # with all hubs as possible endpoints. Traffic between hubs is
11692        # prevented by automatically added pathrestrictions.
11693
21
24
        for my $spoke_net (@$real_spokes) {
11694
25
90
            (my $net_name = $spoke_net->{name}) =~ s/network://;
11695
25
25
27
41
            push @{ $crypto->{tunnels} }, $spoke_net;
11696
25
30
            my $spoke = $spoke_net->{interfaces}->[0];
11697
25
27
            $spoke->{crypto} = $crypto;
11698
25
21
            my $real_spoke = $spoke->{real_interface};
11699
25
25
            $real_spoke->{spoke} = $crypto;
11700
11701            # Each spoke gets a fresh hub interface.
11702
25
20
            my @hubs;
11703
25
32
            for my $real_hub (@$real_hubs) {
11704
25
24
                my $router = $real_hub->{router};
11705
25
40
                if (my $orig_router = $router->{orig_router}) {
11706
22
19
                    $router = $orig_router;
11707                }
11708
25
25
                my $hardware = $real_hub->{hardware};
11709
25
142
                (my $intf_name = $real_hub->{name}) =~ s/\..*$/.$net_name/;
11710
25
47
                my $hub = new(
11711                    'Interface',
11712                    name           => $intf_name,
11713                    ip             => 'tunnel',
11714                    crypto         => $crypto,
11715
11716                    # Attention: shared hardware between router and
11717                    # orig_router.
11718                    hardware       => $hardware,
11719                    is_hub         => 1,
11720                    real_interface => $real_hub,
11721                    router         => $router,
11722                    network        => $spoke_net
11723                );
11724
25
48
                $hub->{bind_nat} = $real_hub->{bind_nat}
11725                  if $real_hub->{bind_nat};
11726
25
25
21
30
                push @{ $router->{interfaces} },      $hub;
11727
25
25
27
25
                push @{ $hardware->{interfaces} },    $hub;
11728
25
25
18
24
                push @{ $spoke_net->{interfaces} },   $hub;
11729
25
25
20
38
                push @{ $hub->{peers} },              $spoke;
11730
25
25
18
37
                push @{ $spoke->{peers} },            $hub;
11731
25
29
                push @hubs, $hub;
11732
11733                # We need hub also be available in orig_interfaces.
11734
25
45
                if (my $aref = $router->{orig_interfaces}) {
11735
22
24
                    push @$aref, $hub;
11736                }
11737
11738
25
108
                if ($real_spoke->{ip} =~ /^(?:negotiated|short|unnumbered)$/) {
11739
10
9
                    my $model = $router->{model};
11740
10
27
                    if (not ( $model->{do_auth} or $model->{can_dyn_crypto})) {
11741
0
0
                        err_msg "$router->{name} can't establish crypto",
11742                          " tunnel to $real_spoke->{name} with unknown IP";
11743                    }
11744                }
11745
11746
25
35
                if ($private) {
11747
0
0
                    my $s_p = $real_spoke->{private};
11748
0
0
                    my $h_p = $real_hub->{private};
11749
0
0
                    $s_p and $s_p eq $private
11750                      or $h_p and $h_p eq $private
11751                      or err_msg
11752                      "Tunnel $real_spoke->{name} to $real_hub->{name}",
11753                      " of $private.private $name",
11754                      " must reference at least one object",
11755                      " out of $private.private";
11756                }
11757                else {
11758
25
39
                    $real_spoke->{private}
11759                      and err_msg "Tunnel of public $name must not",
11760                      " reference $real_spoke->{name} of",
11761                      " $real_spoke->{private}.private";
11762
25
78
                    $real_hub->{private}
11763                      and err_msg "Tunnel of public $name must not",
11764                      " reference $real_hub->{name} of",
11765                      " $real_hub->{private}.private";
11766                }
11767            }
11768
11769
25
32
            my $router = $spoke->{router};
11770
25
16
            my @other;
11771            my $has_id_hosts;
11772
25
25
21
31
            for my $interface (@{ $router->{interfaces} }) {
11773
56
50
                my $network = $interface->{network};
11774
56
119
                if ($network->{has_id_hosts}) {
11775
12
11
                    $has_id_hosts = $network;
11776                }
11777                elsif ($interface->{ip} ne 'tunnel')
11778                {
11779
19
23
                    push @other, $interface;
11780                }
11781            }
11782
25
68
            if ($has_id_hosts and @other) {
11783
0
0
                err_msg "Must not use $has_id_hosts->{name} with ID hosts",
11784                  " together with networks having no ID host: ",
11785
0
0
                  join(',', map { $_->{name} } @other);
11786            }
11787
25
20
            push @real_interfaces, $real_spoke;
11788
11789
25
52
            if ($router->{managed} && $crypto->{detailed_crypto_acl}) {
11790
0
0
                err_msg(
11791                    "Attribute 'detailed_crypto_acl' is not",
11792                    " allowed for managed spoke $router->{name}"
11793                );
11794            }
11795
11796            # Automatically add pathrestriction between interfaces
11797            # of redundant hubs.
11798
25
86
            if (@hubs > 1) {
11799
0
0
                my $name2 = "auto-restriction:$crypto->{name}";
11800
0
0
                add_pathrestriction($name, \@hubs);
11801            }
11802        }
11803    }
11804
11805    # Check for undefined crypto references.
11806
337
550
    for my $crypto (keys %crypto2hubs) {
11807
0
0
0
0
        for my $interface (@{ $crypto2hubs{$crypto} }) {
11808
0
0
            err_msg("$interface->{name} references unknown $crypto");
11809        }
11810    }
11811
337
521
    for my $crypto (keys %crypto2spokes) {
11812
0
0
0
0
        for my $network (@{ $crypto2spokes{$crypto} }) {
11813
0
0
            err_msg "$network->{interfaces}->[0]->{name}",
11814              " references unknown $crypto";
11815        }
11816    }
11817
337
430
    return;
11818}
11819
11820# Needed for crypto_rules,
11821# for default route optimization,
11822# while generating chains of iptables and
11823# for local optimization.
11824my $network_00 = new(
11825    'Network',
11826    name         => "network:0/0",
11827    ip           => 0,
11828    mask         => 0,
11829    is_aggregate => 1,
11830    is_supernet  => 1
11831);
11832
11833sub crypto_behind {
11834
28
0
26
    my ($interface, $managed) = @_;
11835
28
35
    if ($managed) {
11836
4
3
        my $zone = $interface->{zone};
11837
4
4
4
9
        1 == @{ $zone->{interfaces} }
11838          or err_msg "Exactly one security zone must be located behind",
11839          " managed crypto $interface->{name}";
11840
4
5
        my $zone_networks = $zone->{networks};
11841
4
6
        return @$zone_networks;
11842    }
11843    else {
11844
24
23
        my $network = $interface->{network};
11845
24
24
17
41
        1 == @{ $network->{interfaces} }
11846          or err_msg "Exactly one network must be located behind",
11847          " unmanaged crypto $interface->{name}";
11848
24
43
        return($network);
11849    }
11850}
11851
11852# Valid group-policy attributes.
11853# Hash describes usage:
11854# - tg_general: attribute is only applicable to 'tunnel-group general-attributes'
11855my %asa_vpn_attributes = (
11856
11857    # group-policy attributes
11858    banner                    => {},
11859    'check-subject-name'      => {},
11860    'dns-server'              => {},
11861    'default-domain'          => {},
11862    'split-dns'               => {},
11863    'trust-point'             => {},
11864    'wins-server'             => {},
11865    'vpn-access-hours'        => {},
11866    'vpn-idle-timeout'        => {},
11867    'vpn-session-timeout'     => {},
11868    'vpn-simultaneous-logins' => {},
11869    vlan                      => {},
11870    'split-tunnel-policy'     => {},
11871    'authentication-server-group' => { tg_general => 1 },
11872    'authorization-server-group'  => { tg_general => 1 },
11873    'authorization-required'      => { tg_general => 1 },
11874    'username-from-certificate'   => { tg_general => 1 },
11875);
11876
11877sub verify_asa_vpn_attributes {
11878
38
0
31
    my ($obj) = @_;
11879
38
62
    my $attributes = $obj->{radius_attributes} or return;
11880
38
83
    for my $key (sort keys %$attributes) {
11881
32
43
        my $spec  = $asa_vpn_attributes{$key};
11882
32
42
        $spec or err_msg("Invalid radius_attribute '$key' at $obj->{name}");
11883
32
74
        if ($key eq 'split-tunnel-policy') {
11884
3
6
            my $value = $attributes->{$key};
11885
3
21
            $value =~ /^(?:tunnelall|tunnelspecified)$/
11886                or err_msg("Unsupported value in radius_attributes",
11887                           " of $obj->{name}\n",
11888                           " '$key = $value'");
11889        }
11890        elsif ($key eq 'trust-point') {
11891
14
24
            if (is_host($obj)) {
11892
3
9
                $obj->{range} or
11893                    err_msg("Must not use radius_attribute '$key'",
11894                            " at $obj->{name}");
11895            }
11896            elsif (is_network($obj)) {
11897
3
6
3
3
13
5
                grep { $_->{ip} } @{ $obj->{hosts} } and
11898                    err_msg("Must not use radius_attribute '$key'",
11899                            " at $obj->{name}");
11900            }                    
11901        }
11902    }    
11903
38
43
    return;
11904}
11905
11906# Host with ID that doesn't contain a '@' must use attribute 'verify-subject-name'.
11907sub verify_subject_name {
11908
18
0
16
    my ($host, $peers) = @_;
11909
18
22
    my $id = $host->{id};
11910
18
60
    return if $id =~ /@/;
11911    my $has_attr = sub {
11912
3
4
        my ($obj) = @_;
11913
3
5
        my $attributes = $obj->{radius_attributes};
11914
3
24
        return ($attributes && $attributes->{'check-subject-name'});
11915
3
10
    };
11916
3
5
    return if $has_attr->($host);
11917
0
0
    return if $has_attr->($host->{network});
11918
0
0
    my $missing;
11919
0
0
    for my $peer (@$peers) {
11920
0
0
        next if $has_attr->($peer->{router});
11921
0
0
        $missing = 1;
11922    }
11923
0
0
    if ($missing) {
11924
0
0
        err_msg("Missing radius_attribute 'check-subject-name'\n",
11925                " for $host->{name}");
11926    }
11927
0
0
    return;
11928}
11929
11930sub verify_asa_trustpoint {
11931
11
0
11
    my ($router, $crypto) = @_;
11932
11
13
    my $isakmp = $crypto->{type}->{key_exchange};
11933
11
19
    if ($isakmp->{authentication} eq 'rsasig') {
11934
9
18
        $isakmp->{trust_point} or
11935            err_msg("Missing attribute 'trust_point' in",
11936                    " $isakmp->{name} for $router->{name}");
11937    }
11938
11
22
    return;
11939}
11940
11941sub expand_crypto  {
11942
239
0
309
    progress('Expanding crypto rules');
11943
11944
239
191
    my %id2interface;
11945
11946
239
423
    for my $crypto (values %crypto) {
11947
20
23
        my $name = $crypto->{name};
11948
20
25
        my $isakmp = $crypto->{type}->{key_exchange};
11949
20
26
        my $need_id = $isakmp->{authentication} eq 'rsasig';
11950
11951        # Do consistency checks and
11952        # add rules which allow encrypted traffic.
11953
20
20
16
29
        for my $tunnel (@{ $crypto->{tunnels} }) {
11954
22
37
            next if $tunnel->{disabled};
11955
22
22
15
28
            for my $tunnel_intf (@{ $tunnel->{interfaces} }) {
11956
44
107
                next if $tunnel_intf->{is_hub};
11957
22
21
                my $router  = $tunnel_intf->{router};
11958
22
19
                my $peers   = $tunnel_intf->{peers};
11959
22
19
                my $managed = $router->{managed};
11960
22
27
                my @encrypted;
11961                my $has_id_hosts;
11962
0
0
                my $has_other_network;
11963
0
0
                my @verify_radius_attributes;
11964
22
22
17
27
                for my $interface (@{ $router->{interfaces} }) {
11965
50
125
                    next if $interface eq $tunnel_intf;
11966
28
43
                    if ($interface->{ip} eq 'tunnel') {
11967
0
0
                        if ($managed && $router->{model}->{crypto} eq 'EZVPN') {
11968
0
0
                            err_msg "Exactly 1 crypto tunnel expected",
11969                                " for $router->{name} with EZVPN";
11970                        }
11971
0
0
                        next;
11972                    }
11973
28
44
                    if ($interface->{spoke}) {
11974
0
0
                        if (my $id = $interface->{id}) {
11975
0
0
                            if (my $intf2 = $id2interface{$id}) {
11976
0
0
                                err_msg "Same ID '$id' is used at",
11977                                  " $interface->{name} and $intf2->{name}";
11978                            }
11979
0
0
                            $id2interface{$id} = $interface;
11980                        }
11981
0
0
                        next;
11982                    }
11983
28
27
                    my $network = $interface->{network};
11984
28
36
                    my @all_networks = crypto_behind($interface, $managed);
11985
28
35
                    if ($network->{has_id_hosts}) {
11986
12
11
                        $has_id_hosts = 1;
11987
12
18
                        $managed
11988                          and err_msg
11989                          "$network->{name} having ID hosts must not",
11990                          " be located behind managed $router->{name}";
11991
12
12
                        push @verify_radius_attributes, $network;
11992
11993                        # Must not have multiple networks.
11994
12
20
                        @all_networks > 1 and internal_err();
11995
11996                        # Rules for single software clients are stored
11997                        # individually at crypto hub interface.
11998
12
12
12
14
                        for my $host (@{ $network->{hosts} }) {
11999
18
19
                            my $id     = $host->{id};
12000
12001                            # ID host has already been checked to have
12002                            # exacly one subnet.
12003
18
18
                            my $subnet = $host->{subnets}->[0];
12004
18
15
                            push @verify_radius_attributes, $host;
12005
18
19
                            for my $peer (@$peers) {
12006
18
14
                                my $no_nat_set = $peer->{no_nat_set};
12007
18
38
                                if (my $other = $peer->{id_rules}->{$id}) {
12008
1
2
                                    my $src = $other->{src};
12009
1
12
                                    err_msg("Duplicate ID-host $id from",
12010                                            " $src->{network}->{name} and",
12011                                            " $subnet->{network}->{name}",
12012                                            " at $peer->{router}->{name}");
12013
1
3
                                    next;
12014                                }
12015
17
105
                                $peer->{id_rules}->{$id} = {
12016                                    name       => "$peer->{name}.$id",
12017                                    ip         => 'tunnel',
12018                                    src        => $subnet,
12019                                    no_nat_set => $no_nat_set,
12020
12021                                    # Needed during local_optimization.
12022                                    router => $peer->{router},
12023                                };
12024                            }
12025                        }
12026
12
21
                        push @encrypted, $network;
12027                    }
12028                    else {
12029
16
16
                        $has_other_network = 1;
12030
16
25
                        push @encrypted, @all_networks;
12031                    }
12032                }
12033                $has_id_hosts
12034
0
0
                  and $has_other_network
12035                  and err_msg(
12036                    "Must not use host with ID and network",
12037                    " together at $tunnel_intf->{name}: ",
12038
22
56
                    join(', ', map { $_->{name} } @encrypted)
12039                  );
12040
0
0
                     $has_id_hosts
12041                  or $has_other_network
12042                  or err_msg(
12043                    "Must use network or host with ID",
12044                    " at $tunnel_intf->{name}: ",
12045
22
56
                    join(', ', map { $_->{name} } @encrypted)
12046                  );
12047
12048
22
22
                my $real_spoke = $tunnel_intf->{real_interface};
12049
22
22
                for my $peer (@$peers) {
12050
22
28
                    $peer->{peer_networks} = \@encrypted;
12051
22
20
                    my $router  = $peer->{router};
12052
22
24
                    my $do_auth = $router->{model}->{do_auth};
12053
22
50
                    my $unknown_ip =
12054                        $real_spoke->{ip} =~
12055                        /^(?:negotiated|short|unnumbered)$/;
12056
22
48
                    if ($tunnel_intf->{id}) {
12057
9
20
                        $need_id or
12058                            err_msg("Invalid attribute 'id' at",
12059                                    " $tunnel_intf->{name}.\n",
12060                                    " Set authentication=rsasig at",
12061                                    " $isakmp->{name}");
12062                    }
12063                    elsif ($encrypted[0]->{has_id_hosts}) {
12064
10
25
                        $do_auth
12065                          or err_msg("$router->{name} can't check IDs",
12066                                     " of $encrypted[0]->{name}");
12067                    }
12068                    elsif ($need_id) {
12069
1
5
                        err_msg("$tunnel_intf->{name}",
12070                                " needs attribute 'id',",
12071                                " because $isakmp->{name}",
12072                                " has authentication=rsasig");
12073                    }
12074                }
12075
12076
22
22
32
61
                if (grep({ $_->{router}->{model}->{crypto} eq 'ASA_VPN' }
12077                         @$peers))
12078                {
12079
11
20
                    for my $obj (@verify_radius_attributes) {
12080
30
38
                        verify_asa_vpn_attributes($obj);
12081
30
34
                        if (is_host($obj)) {
12082
18
21
                            verify_subject_name($obj, $peers);
12083                        }
12084                    }
12085                }
12086
12087
22
52
                if ($managed && $router->{model}->{crypto} eq 'ASA') {
12088
0
0
                    verify_asa_trustpoint($router, $crypto);
12089                }                    
12090
12091                # Add rules to permit crypto traffic between
12092                # tunnel endpoints.
12093                # If one tunnel endpoint has no known IP address,
12094                # some rules have to be added manually.
12095
22
105
                if (    $real_spoke
12096                    and $real_spoke->{ip} !~ /^(?:short|unnumbered)$/)
12097                {
12098
15
15
13
18
                    for my $hub (@{ $tunnel_intf->{peers} }) {
12099
15
15
                        my $real_hub = $hub->{real_interface};
12100
15
30
                        for my $pair (
12101                            [ $real_spoke, $real_hub ],
12102                            [ $real_hub,   $real_spoke ]
12103                          )
12104                        {
12105
30
27
                            my ($intf1, $intf2) = @$pair;
12106
12107                            # Don't generate incoming ACL from unknown
12108                            # address.
12109
30
50
                            next if $intf1->{ip} eq 'negotiated';
12110
27
43
                            my $rules_ref =
12111                              gen_tunnel_rules($intf1, $intf2,
12112                                $crypto->{type});
12113
27
27
20
42
                            push @{ $expanded_rules{permit} }, @$rules_ref;
12114
27
36
                            add_rules $rules_ref;
12115                        }
12116                    }
12117                }
12118            }
12119        }
12120    }
12121
12122    # Check for duplicate IDs of different hosts
12123    # coming into different hardware at current device.
12124    # ASA_VPN can't distinguish different hosts with same ID
12125    # coming into different hardware interfaces.
12126
239
332
    for my $router (@managed_crypto_hubs) {
12127
16
18
        my $model = $router->{model};
12128
16
30
        my $crypto = $model->{crypto} or next;
12129
16
35
        $crypto eq 'ASA_VPN' or next;
12130
19
27
        my @id_rules_interfaces =
12131
8
8
8
11
            grep { $_->{id_rules} } @{ $router->{interfaces} };
12132
8
19
        @id_rules_interfaces >= 2 or next;
12133
3
3
        my %id2src;
12134
3
6
        for my $interface (@id_rules_interfaces) {
12135
6
7
            my $hash = $interface->{id_rules};
12136
6
10
            for my $id (keys %$hash) {
12137
10
13
                my $src1 = $hash->{$id}->{src};
12138
10
16
                if (my $src2 = $id2src{$id}) {
12139
1
6
                    err_msg("Duplicate ID-host $id from",
12140                            " $src1->{network}->{name} and",
12141                            " $src2->{network}->{name}",
12142                            " at $router->{name}");
12143                }
12144                else {
12145
9
21
                    $id2src{$id} = $src1;
12146                }
12147            }
12148        }
12149    }
12150
12151
239
619
    for my $router (@managed_crypto_hubs) {
12152
16
20
        my $crypto_type = $router->{model}->{crypto};
12153
16
31
        if ($crypto_type eq 'ASA_VPN') {
12154
8
12
            verify_asa_vpn_attributes($router);
12155
12156            # Move 'trust-point' from radius_attributes to router attribute.
12157
8
19
            my $trust_point =
12158                delete $router->{radius_attributes}->{'trust-point'}
12159                or err_msg("Missing 'trust-point' in radius_attributes",
12160                           " of $router->{name}");
12161
8
18
            $router->{trust_point} = $trust_point;
12162        }
12163        elsif($crypto_type eq 'ASA') {
12164
8
8
7
9
            for my $interface (@{ $router->{interfaces} }) {
12165
19
34
                my $crypto = $interface->{crypto} or next;
12166
11
15
                verify_asa_trustpoint($router, $crypto);
12167            }
12168        }     
12169    }
12170
12171    # Hash only needed during expand_group and expand_rules.
12172
239
280
    %auto_interfaces = ();
12173
239
244
    return;
12174}
12175
12176# Hash for converting a reference of an object back to this object.
12177my %ref2obj;
12178
12179sub setup_ref2obj  {
12180
226
0
272
    for my $network (@networks) {
12181
938
1275
        $ref2obj{$network} = $network;
12182
938
938
938
706
1082
1127
        for my $obj (@{ $network->{subnets} }, @{ $network->{interfaces} }) {
12183
1332
2536
            $ref2obj{$obj} = $obj;
12184        }
12185    }
12186
226
220
    return;
12187}
12188
12189##############################################################################
12190# Check if high-level and low-level semantics of rules with an supernet
12191# as source or destination are equivalent.
12192#
12193# I. Typically, we only use incoming ACLs.
12194# (A) rule "permit any:X dst"
12195# high-level: any:X in zone X get access to dst
12196# low-level: like above, but additionally, the networks matching any:X
12197#            in all zones on the path from zone X to dst get access to dst.
12198# (B) rule permit src any:X
12199# high-level: src gets access to any:X in zone X
12200# low-level: like above, but additionally, src gets access to all networks
12201#            matching any:X in all zones located directly behind
12202#            all routers on the path from src to zone X.
12203#
12204# II. Alternatively, we have a single interface Y (with attached zone Y)
12205#     without ACL and all other interfaces having incoming and outgoing ACLs.
12206# (A) rule "permit any:X dst"
12207#  a)  dst behind Y: filtering occurs at incoming ACL of X, good.
12208#  b)  dst not behind Y:
12209#    1. zone X == zone Y: filtering occurs at outgoing ACL, good.
12210#    2. zone X != zone Y: outgoing ACL would accidently
12211#                permit any:Y->dst, bad.
12212#                Additional rule required: "permit any:Y->dst"
12213# (B) rule "permit src any:X"
12214#  a)  src behind Y: filtering occurs at ougoing ACL, good
12215#  b)  src not behind Y:
12216#    1. zone X == zone Y: filtering occurs at incoming ACL at src and
12217#                at outgoing ACls of other non-zone X interfaces, good.
12218#    2. zone X != zone Y: incoming ACL at src would permit
12219#                src->any:Y, bad
12220#                Additional rule required: "permit src->any:Y".
12221##############################################################################
12222
12223my %supernet_rule_tree;
12224
12225# Collect rules with destination aggregate/supernet
12226# - that are filtered at the same router which is attached
12227#   to the destination zone
12228# - the destination router is entered by the same interface
12229# - src, src_range, prt, stateless are identical
12230# - dst is supernet or aggregate with identical ip/mask
12231sub collect_supernet_dst_rules {
12232
12233    # Function is called from path_walk.
12234
86
0
1138
    my ($rule, $in_intf, $out_intf) = @_;
12235
12236    # Source is interface of current router.
12237
86
123
    return if !$in_intf;
12238
12239    # Ignore semi_managed router.
12240
78
77
    my $router = $in_intf->{router};
12241
78
129
    return if !$router->{managed};
12242
12243
75
70
    my $dst  = $rule->{dst};
12244
75
65
    my $zone = $dst->{zone};
12245
75
171
    return if $out_intf->{zone} ne $zone;
12246
12247    # Get NAT address of supernet.
12248
54
88
    if (!$dst->{is_aggregate}) {
12249
21
16
        my $no_nat_set = $in_intf->{no_nat_set};
12250
21
31
        my $dst = get_nat_network($dst, $no_nat_set);
12251
21
51
        return if $dst->{hidden};
12252    }
12253
12254
54
54
44
123
    my $ipmask = join('/', @{$dst}{qw(ip mask)});
12255
54
73
    my ($stateless, $src, $src_range, $prt) =
12256
54
57
      @{$rule}{qw(stateless src src_range prt)};
12257
54
149
    $stateless ||= '';
12258
54
124
    $src_range ||= $prt_ip;
12259
54
242
    $supernet_rule_tree{$stateless}->{$src}->{$src_range}->{$prt}
12260                       ->{$in_intf}->{$ipmask}->{$zone} = $rule;
12261
54
98
    return;
12262}
12263
12264sub find_supernet {
12265
3
0
3
    my ($net1, $net2) = @_;
12266
12267    # Start with $net1 being the smaller network.
12268
3
8
    ($net1, $net2) = ($net2, $net1) if $net1->{mask} < $net2->{mask};
12269
3
3
    while (1) {
12270
4
8
        while ($net1->{mask} > $net2->{mask}) {
12271
2
7
            $net1 = $net1->{up} or return;
12272        }
12273
3
10
        return $net1 if $net1 eq $net2;
12274
2
7
        $net2 = $net2->{up} or return;
12275    }
12276
0
0
    return; # unused; only for perlcritic
12277}
12278
12279# Find networks in zone with address
12280# - equal to ip/mask or
12281# - subnet of ip/mask
12282# Leave out small networks which are subnet of a matching network.
12283# Result:
12284# 0: no network found
12285# network:
12286#   a) exactly one network matches, i.e. is equal or subnet.
12287#   b) a supernet which encloses multiple matching networks
12288# String: More than one network found and no supernet exists.
12289#         String has the name of first two networks.
12290sub find_zone_network {
12291
59
0
59
    my ($interface, $zone, $other) = @_;
12292
59
55
    my $no_nat_set = $interface->{no_nat_set};
12293
59
77
    my $nat_other = get_nat_network($other, $no_nat_set);
12294
59
101
    return 0 if $nat_other->{hidden};
12295
59
59
50
85
    my ($ip, $mask) = @{$nat_other}{qw(ip mask)};
12296
59
95
    my $key = "$ip/$mask";
12297
59
115
    if (my $aggregate = $zone->{ipmask2aggregate}->{$key}) {
12298
7
13
        return $aggregate;
12299    }
12300
52
109
    if (my $result = $zone->{ipmask2net}->{$key}) {
12301
0
0
        return $result;
12302    }
12303
12304    # Real networks in zone without aggregates and without subnets.
12305
52
44
    my $networks = $zone->{networks};
12306
52
43
    my $result   = 0;
12307
52
75
    for my $network (@$networks) {
12308
57
65
        my $nat_network = get_nat_network($network, $no_nat_set);
12309
57
91
        next if $nat_network->{hidden};
12310
57
57
50
71
        my ($i, $m) = @{$nat_network}{qw(ip mask)};
12311
57
138
        next if $i =~ /^(?:unnumbered|tunnel)$/;
12312
12313
57
216
        if (   $m >= $mask && match_ip($i, $ip, $mask)
12314            || $m < $mask && match_ip($ip, $i, $m))
12315        {
12316
12317            # Found first matching network.
12318
24
35
            if (!$result) {
12319
21
16
                $result = $network;
12320
21
37
                next;
12321            }
12322
12323            # Search a common supernet of two networks
12324
3
9
            if (my $super = find_supernet($result, $network)) {
12325
1
2
                $result = $super;
12326            }
12327            else {
12328
2
5
                $result = "$result->{name}, $network->{name}";
12329
2
4
                last;
12330            }
12331        }
12332    }
12333#    debug "zone_network:", ref($result) ? $result->{name} : $result;
12334
52
116
    return ($zone->{ipmask2net}->{$key} = $result);
12335}
12336
12337# Find all networks in zone, which match network from other zone.
12338# Result:
12339# undef: No network of zone matches $other.
12340# []   : Multiple networks match, but no supernet exists.
12341# [N, ..]: Array reference to networks which match $other (ascending order).
12342sub find_matching_supernet {
12343
59
0
62
    my ($interface, $zone, $other) = @_;
12344
59
79
    my $net_or_count = find_zone_network($interface, $zone, $other);
12345
12346    # No network or aggregate matches.
12347    # $other wont match in current zone.
12348
59
97
    if (!$net_or_count) {
12349
31
38
        return;
12350    }
12351
12352    # More than one network matches and no supernet exists.
12353    # Return names of that networks.
12354
28
44
    if (!ref($net_or_count)) {
12355
2
4
        return $net_or_count;
12356    }
12357
12358    # Exactly one network or aggregate matches or supernet exists.
12359
26
28
    my @result;
12360
12361    # Add enclosing supernets.
12362
26
30
    my $up = $net_or_count;
12363
26
42
    while ($up) {
12364
28
30
        push @result, $up;
12365
28
53
        $up = $up->{up};
12366    }
12367#    debug "matching:", join(',', map { $_->{name} } @result);
12368
26
35
    return \@result;
12369}
12370
12371# Prevent multiple error messages about missing supernet rules;
12372my %missing_supernet;
12373
12374# $rule: the rule to be checked
12375# $where: has value 'src' or 'dst'
12376# $interface: interface, where traffic reaches the device,
12377#             this is used to determine no_nat_set
12378# $zone: The zone to be checked.
12379#        If $where is 'src', then $zone is attached to $interface
12380#        If $where is 'dst', then $zone is at other side of device.
12381# $reversed: (optional) the check is for reversed rule at stateless device
12382sub check_supernet_in_zone {
12383
68
0
109
    my ($rule, $where, $interface, $zone, $reversed) = @_;
12384
12385
68
126
    my ($stateless, $deny, $src, $dst, $src_range, $prt) =
12386
68
61
      @{$rule}{qw(stateless deny src dst src_range prt)};
12387
68
181
    $stateless ||= '';
12388
68
163
    $src_range ||= $prt_ip;
12389
68
96
    my $other = $where eq 'src' ? $src : $dst;
12390
12391    # Fast check for access to aggregate/supernet with identical
12392    # ip/mask to $zone.
12393
68
102
    if ($where eq 'dst') {
12394
12395        # Get NAT address of supernet.
12396
49
79
        if (!$dst->{is_aggregate}) {
12397
16
17
            my $no_nat_set = $interface->{no_nat_set};
12398
16
19
            $dst = get_nat_network($dst, $no_nat_set);
12399
16
30
            return if $dst->{hidden};
12400        }
12401
49
49
42
85
        my $ipmask = join('/', @{$dst}{qw(ip mask)});
12402
49
233
        return if $supernet_rule_tree{$stateless}->{$src}->{$src_range}
12403                  ->{$prt}->{$interface}->{$ipmask}->{$zone};
12404    }
12405
12406
59
88
    my $networks = find_matching_supernet($interface, $zone, $other);
12407
59
126
    return if not $networks;
12408
28
23
    my $extra;
12409
28
51
    if (!ref($networks)) {
12410
2
3
        $extra = "No supernet available for $networks";
12411    }
12412    else {
12413
12414        # $networks holds matching network and all its supernets.
12415        # Find first matching rule.
12416
26
73
        $deny ||= '';
12417
26
32
        for my $network (@$networks) {
12418
28
43
            ($where eq 'src' ? $src : $dst) = $network;
12419
28
109
            if ($rule_tree{$stateless}->{$deny}->{$src_range}->{$src}
12420                ->{$dst}->{$prt})
12421            {
12422
17
41
                return;
12423            }
12424        }
12425
9
9
11
25
        $extra = "Tried " . join(', ', map { $_->{name} } @$networks);
12426    }
12427
12428
11
14
    my $service = $rule->{rule}->{service};
12429
11
34
    return if $missing_supernet{$interface}->{$service};
12430
8
17
    $missing_supernet{$interface}->{$service} = 1;
12431
12432
8
10
    $rule = print_rule $rule;
12433
8
14
    $reversed = $reversed ? 'reversed ' : '';
12434
8
18
    my $print =
12435      $config{check_supernet_rules} eq 'warn' ? \&warn_msg : \&err_msg;
12436
8
51
    $print->(
12437        "Missing rule for ${reversed}supernet rule.\n",
12438        " $rule\n",
12439        " can't be effective at $interface->{name}.\n",
12440        " $extra as $where."
12441    );
12442
8
25
    return;
12443}
12444
12445# If such rule is defined
12446#  permit supernet1 dst
12447#
12448# and topology is like this:
12449#
12450# supernet1-R1-zone2-R2-zone3-R3-dst
12451#               zone4-/
12452#
12453# additional rules need to be defined as well:
12454#  permit supernet(zone2) dst
12455#  permit supernet(zone3) dst
12456#
12457# If R2 is stateless, we need one more rule to be defined:
12458#  permit supernet(zone4) dst
12459# This is so, because at R2 we would get an automatically generated
12460# reverse rule
12461#  permit dst supernet1
12462# which would accidentally permit traffic to supernet:[zone4] as well.
12463sub check_supernet_src_rule {
12464
12465    # Function is called from path_walk.
12466
91
0
95
    my ($rule, $in_intf, $out_intf) = @_;
12467
12468    # Destination is interface of current router and therefore there is
12469    # nothing to be checked.
12470
91
134
    return unless $out_intf;
12471
12472    # Ignore semi_managed router.
12473
78
83
    my $router = $in_intf->{router};
12474
78
118
    return if not $router->{managed};
12475
12476
74
68
    my $out_zone = $out_intf->{zone};
12477
74
69
    my $dst      = $rule->{dst};
12478
74
154
    my $dst_zone = get_zone($dst);
12479
74
172
    if ($dst->{is_supernet} && $out_zone eq $dst_zone) {
12480
12481        # Both src and dst are supernets and are directly connected
12482        # at current router. Hence there can't be any missing rules.
12483        # Note: Additional checks will be done for this situation at
12484        # check_supernet_dst_rule
12485
8
13
        return;
12486    }
12487
66
56
    my $in_zone = $in_intf->{zone};
12488
12489    # Check case II, outgoing ACL, (A)
12490
66
51
    my $no_acl_intf;
12491
66
115
    if ($no_acl_intf = $router->{no_in_acl}) {
12492
2
1
        my $no_acl_zone = $no_acl_intf->{zone};
12493
12494        # a) dst behind Y
12495
2
8
        if ($no_acl_zone eq $dst_zone) {
12496        }
12497
12498        # b), 1. zone X == zone Y
12499        elsif ($in_zone eq $no_acl_zone) {
12500        }
12501
12502        elsif ($no_acl_intf->{main_interface}) {
12503        }
12504
12505        # b), 2. zone X != zone Y
12506        else {
12507
0
0
            check_supernet_in_zone($rule, 'src', $no_acl_intf, $no_acl_zone);
12508        }
12509    }
12510
66
61
    my $src      = $rule->{src};
12511
66
62
    my $src_zone = $src->{zone};
12512
12513    # Check if reverse rule would be created and would need additional rules.
12514
66
137
    if ($router->{model}->{stateless} && !$rule->{oneway})
12515
12516    {
12517
4
6
        my $proto = $rule->{prt}->{proto};
12518
12519        # Reverse rule wouldn't allow too much traffic, if a non
12520        # secondary stateful device filters between current device and dst.
12521        # This is true if $out_zone and $dst_zone have different
12522        # {stateful_mark}.
12523        # If dst is managed interface, {stateful_mark} is undef
12524        # - if device is secondary managed, take mark of attached network
12525        # - else take value -1, different from all marks.
12526        # $src is supernet (not an interface) by definition
12527        # and hence $m1 is well defined.
12528
4
4
        my $m1 = $out_zone->{stateful_mark};
12529
4
3
        my $m2 = $dst_zone->{stateful_mark};
12530
4
7
        if (!$m2) {
12531
0
0
            my $managed = $dst->{router}->{managed};
12532
0
0
            $m2 =
12533                $managed =~ /^(?:secondary|local.*)$/
12534              ? $dst->{network}->{zone}->{stateful_mark}
12535              : -1;
12536        }
12537
4
24
        if (($proto eq 'tcp' || $proto eq 'udp' || $proto eq 'ip')
12538            && $m1 == $m2)
12539        {
12540
12541            # Check case II, outgoing ACL, (B), interface Y without ACL.
12542
2
3
            if (my $no_acl_intf = $router->{no_in_acl}) {
12543
0
0
                my $no_acl_zone = $no_acl_intf->{zone};
12544
12545                # a) dst behind Y
12546
0
0
                if ($no_acl_zone eq $dst_zone) {
12547                }
12548
12549                # b) dst not behind Y
12550                # zone X == zone Y
12551                elsif ($no_acl_zone eq $src_zone) {
12552                }
12553
12554                elsif ($no_acl_intf->{main_interface}) {
12555                }
12556
12557                # zone X != zone Y
12558                else {
12559
0
0
                    check_supernet_in_zone($rule, 'src', $no_acl_intf,
12560                        $no_acl_zone, 1);
12561                }
12562            }
12563
12564            # Standard incoming ACL at all interfaces.
12565            else {
12566
12567                # Find security zones at all interfaces except the in_intf.
12568
2
2
3
2
                for my $intf (@{ $router->{interfaces} }) {
12569
4
16
                    next if $intf eq $in_intf;
12570
2
5
                    next if $intf->{loopback} && ! $intf->{vip};
12571
12572                    # Nothing to be checked for an interface directly
12573                    # connected to src or dst.
12574
2
1
                    my $zone = $intf->{zone};
12575
2
5
                    next if $zone eq $src_zone;
12576
2
5
                    next if $zone eq $dst_zone;
12577
0
0
                    next if $intf->{main_interface};
12578
0
0
                    check_supernet_in_zone($rule, 'src', $intf, $zone, 1);
12579                }
12580            }
12581        }
12582    }
12583
12584    # Nothing to do at first router.
12585    # zone2 is checked at R2, because we need the no_nat_set at R2.
12586
66
166
    return if $src_zone eq $in_zone;
12587
12588    # Check if rule "supernet2 -> dst" is defined.
12589
19
36
    check_supernet_in_zone($rule, 'src', $in_intf, $in_zone);
12590
19
27
    return;
12591}
12592
12593# If such rule is defined
12594#  permit src supernet5
12595#
12596# and topology is like this:
12597#
12598#                      /-zone4
12599# src-R1-zone2-R2-zone3-R3-zone5
12600#      \-zone1
12601#
12602# additional rules need to be defined as well:
12603#  permit src supernet1
12604#  permit src supernet2
12605#  permit src supernet3
12606#  permit src supernet4
12607sub check_supernet_dst_rule {
12608
12609    # Function is called from path_walk.
12610
72
0
77
    my ($rule, $in_intf, $out_intf) = @_;
12611
12612    # Source is interface of current router.
12613
72
98
    return unless $in_intf;
12614
12615    # Ignore semi_managed router.
12616
71
69
    my $router = $in_intf->{router};
12617
71
113
    return if not $router->{managed};
12618
12619
71
65
    my $src      = $rule->{src};
12620
71
89
    my $src_zone = get_zone($src);
12621
71
74
    my $dst      = $rule->{dst};
12622
71
72
    my $dst_zone = $dst->{zone};
12623
12624    # Check case II, outgoing ACL, (B), interface Y without ACL.
12625
71
109
    if (my $no_acl_intf = $router->{no_in_acl}) {
12626
7
6
        my $no_acl_zone = $no_acl_intf->{zone};
12627
12628        # a) src behind Y
12629
7
20
        if ($no_acl_zone eq $src_zone) {
12630        }
12631
12632        # b) src not behind Y
12633        # zone X == zone Y
12634        elsif ($no_acl_zone eq $dst_zone) {
12635        }
12636
12637        elsif ($no_acl_intf->{main_interface}) {
12638        }
12639
12640        # zone X != zone Y
12641        else {
12642
3
4
            check_supernet_in_zone($rule, 'dst', $in_intf, $no_acl_zone);
12643        }
12644
7
11
        return;
12645    }
12646
12647    # Check security zones at all interfaces except those connected to dst or src.
12648    # For devices which have rules for each pair of incoming and outgoing
12649    # interfaces we only need to check the direct path to dst.
12650
64
50
111
66
    for my $intf (
12651        $router->{model}->{has_io_acl}
12652        ? ($out_intf)
12653        : @{ $router->{interfaces} }
12654      )
12655    {
12656
12657        # Check each intermediate zone only once at outgoing interface.
12658
159
302
        next if $intf eq $in_intf;
12659
109
257
        next if $intf->{loopback} && ! $intf->{vip};
12660
12661        # Don't check interface where src or dst is attached.
12662
93
79
        my $zone = $intf->{zone};
12663
93
168
        next if $zone eq $src_zone;
12664
92
185
        next if $zone eq $dst_zone;
12665
46
68
        next if $intf->{main_interface};
12666
46
64
        check_supernet_in_zone($rule, 'dst', $in_intf, $zone);
12667    }
12668
64
91
    return;
12669}
12670
12671# Optimization:
12672# Call check_supernet_dst_rule not for every rule with aggregate as destination,
12673# but only once for a set of rules from collect_supernet_dst_rules.
12674sub check_supernet_dst_collections {
12675
226
0
747
    return if !keys %supernet_rule_tree;
12676
32
34
    my @check_rules;
12677
12678
32
43
    for my $src2href (values %supernet_rule_tree) {
12679
32
59
        for my $src_range2href (values %$src2href) {
12680
36
46
            for my $prt2href (values %$src_range2href) {
12681
36
46
                for my $intf2href (values %$prt2href) {
12682
38
49
                    for my $ipmask2href (values %$intf2href) {
12683
12684                        # Check larger aggregates first. To get
12685                        # deterministic error messages.
12686
45
4
85
14
                        for my $ipmask (sort { (split '/', $a)[1] <=>
12687                                               (split '/', $b)[1] }
12688                                        keys %$ipmask2href)
12689                        {
12690
48
46
                            my $zone2rule = $ipmask2href->{$ipmask};
12691
48
194
                            push @check_rules, (values %$zone2rule )[0];
12692                        }
12693                    }
12694                }
12695            }
12696        }
12697    }
12698
32
37
    for my $rule (@check_rules) {
12699
48
78
        path_walk($rule, \&check_supernet_dst_rule);
12700    }
12701
12702    # Not used any longer.
12703
32
107
    %supernet_rule_tree = ();
12704
32
37
    return;
12705}
12706
12707# Find smaller protocol of two protocols.
12708# Cache results.
12709my %smaller_prt;
12710
12711sub find_smaller_prt  {
12712
8
0
8
    my ($prt1, $prt2) = @_;
12713
12714
8
17
    if ($prt1 eq $prt2) {
12715
8
17
        return $prt1;
12716    }
12717
0
0
    if (defined(my $prt = $smaller_prt{$prt1}->{$prt2})) {
12718
0
0
        return $prt;
12719    }
12720
12721
0
0
    my $prt = $prt1;
12722
0
0
    while ($prt = $prt->{up}) {
12723
0
0
        if ($prt eq $prt2) {
12724
0
0
            $smaller_prt{$prt1}->{$prt2} = $prt1;
12725
0
0
            $smaller_prt{$prt2}->{$prt1} = $prt1;
12726
0
0
            return $prt1;
12727        }
12728    }
12729
0
0
    $prt = $prt2;
12730
0
0
    while ($prt = $prt->{up}) {
12731
0
0
        if ($prt eq $prt1) {
12732
0
0
            $smaller_prt{$prt1}->{$prt2} = $prt2;
12733
0
0
            $smaller_prt{$prt2}->{$prt1} = $prt2;
12734
0
0
            return $prt2;
12735        }
12736    }
12737
0
0
    $smaller_prt{$prt1}->{$prt2} = 0;
12738
0
0
    $smaller_prt{$prt2}->{$prt1} = 0;
12739
0
0
    return;
12740}
12741
12742# Example:
12743# XX--R1--any:A--R2--R3--R4--YY
12744#
12745# If we have rules
12746#   permit XX any:A
12747#   permit any:B YY
12748# and
12749#   the intersection I of A and B isn't empty
12750# and
12751#   XX and YY are subnet of I
12752# then this traffic is implicitly permitted
12753#   permit XX YY
12754# which may be undesired.
12755# In order to avoid this, a warning is generated if the implied rule is not
12756# explicitly defined.
12757#
12758# ToDo:
12759# Do we need to check for {zone_cluster} equality?
12760#
12761# Currently we only check aggregates/supernets with mask = 0.
12762# Checking of other aggregates is too complicate (NAT, intersection).
12763
12764# Collect info about unwanted implied rules.
12765sub check_for_transient_supernet_rule {
12766
226
0
188
    my %missing_rule_tree;
12767
226
207
    my $missing_count = 0;
12768
12769
226
226
185
333
    for my $rule (@{ $expanded_rules{supernet} }) {
12770
120
190
        next if $rule->{deleted};
12771
112
170
        next if $rule->{deny};
12772
112
165
        next if $rule->{no_check_supernet_rules};
12773
112
96
        my $dst = $rule->{dst};
12774
112
201
        next if not $dst->{is_supernet};
12775
12776        # Check only 0/0 aggregates.
12777
56
108
        next if $dst->{mask} != 0;
12778
12779        # A leaf security zone has only one interface.
12780        # It can't lead to unwanted rule chains.
12781
26
26
20
62
        next if @{ $dst->{zone}->{interfaces} } <= 1;
12782
12783
8
15
        my ($stateless1, $src1, $dst1, $src_range1, $prt1) =
12784          @$rule{qw(stateless src dst src_range prt)};
12785
8
22
        $stateless1 ||= '';
12786
8
9
        my $deny = '';
12787
8
19
        $src_range1 ||= $prt_ip;
12788
12789        # Find all rules with supernet as source, which intersect with $dst1.
12790
8
7
        my $src2 = $dst1;
12791
8
8
        for my $stateless2 (1, '') {
12792
16
29
         my $hash = $rule_tree{$stateless2} or next;
12793
8
16
         $hash = $hash->{$deny} or next;
12794
8
20
         while (my ($src_range2_str, $hash) = each %$hash) {
12795
8
7
          my $src_range2 = $ref2prt{$src_range2_str};
12796
8
14
          my $smaller_src_range =
12797              find_smaller_prt($src_range1, $src_range2) or next;
12798
12799
8
41
          $hash = $hash->{$src2} or next;
12800
0
0
          while (my ($dst2_str, $hash) = each %$hash) {
12801
12802           # Skip reverse rules.
12803
0
0
           next if $src1 eq $dst2_str;
12804
12805
0
0
           my $dst2 = $ref2obj{$dst2_str};
12806
12807           # Skip rules with src and dst inside a single zone.
12808
0
0
           next if (($obj2zone{$src1} || get_zone $src1) eq
12809                    ($obj2zone{$dst2} || get_zone $dst2));
12810
12811          RULE2:
12812
0
0
           while (my ($prt2_str, $rule2) = each %$hash) {
12813
0
0
            next if $rule2->{no_check_supernet_rules};
12814
12815
0
0
            my $prt2       = $rule2->{prt};
12816
0
0
            my $src_range2 = $rule2->{src_range} || $prt_ip;
12817
12818            # Find smaller protocol of two rules found.
12819
0
0
            my $smaller_prt       = find_smaller_prt($prt1, $prt2);
12820
12821            # If protocols are disjoint, we do not have
12822            # transient-supernet-problem for $rule and $rule2.
12823
0
0
            next if not $smaller_prt;
12824
12825            # Stateless rule < stateful rule, hence use ||.
12826
0
0
            my $stateless = $stateless1 || $stateless2;
12827
12828            # Check for a rule with $src1 and $dst2 and
12829            # with $smaller_prt.
12830
0
0
            while (1) {
12831
0
0
             my $deny = '';
12832
0
0
             if (my $hash = $rule_tree{$stateless}) {
12833
0
0
              while (1) {
12834
0
0
               my $src_range = $smaller_src_range;
12835
0
0
               if (my $hash = $hash->{$deny}) {
12836
0
0
                while (1) {
12837
0
0
                 my $src = $src1;
12838
0
0
                 if (my $hash = $hash->{$src_range}) {
12839
0
0
                  while (1) {
12840
0
0
                   my $dst = $dst2;
12841
0
0
                   if (my $hash = $hash->{$src}) {
12842
0
0
                    while (1) {
12843
0
0
                     my $prt = $smaller_prt;
12844
0
0
                     if (my $hash = $hash->{$dst}) {
12845
0
0
                      while (1) {
12846
0
0
                       if (my $other_rule = $hash->{$prt}) {
12847
12848#                       debug(print_rule $r_rule);
12849
0
0
                        next RULE2;
12850                       }
12851
0
0
                       $prt = $prt->{up} or last;
12852                      }
12853                     }
12854
0
0
                     $dst = $dst->{up} or last;
12855                    }
12856                   }
12857
0
0
                   $src = $src->{up} or last;
12858                  }
12859                 }
12860
0
0
                 $src_range = $src_range->{up} or last;
12861                }
12862               }
12863
0
0
               last if $deny;
12864
0
0
               $deny = 1;
12865              }
12866             }
12867
0
0
             last if !$stateless;
12868
0
0
             $stateless = '';
12869            }
12870
12871#           debug("Src: ", print_rule $rule);
12872#           debug("Dst: ", print_rule $rule2);
12873
0
0
            my $src_service = $rule->{rule}->{service}->{name};
12874
0
0
            my $dst_service = $rule2->{rule}->{service}->{name};
12875
0
0
            my $prt_name    = $smaller_prt->{name};
12876
0
0
            $prt_name =~ s/^.part_/[part]/;
12877
0
0
            if ($smaller_src_range ne $prt_ip) {
12878
0
0
0
0
                my ($p1, $p2) = @{ $smaller_src_range->{range} };
12879
0
0
                $prt_name = "[src:$p1-$p2]$prt_name";
12880            }
12881
0
0
            my $new =
12882                not $missing_rule_tree{$src_service}->{$dst_service}
12883
12884                # The matching supernet object.
12885                ->{ $dst1->{name} }
12886
12887                # The missing rule
12888                ->{ $src1->{name} }->{ $dst2->{name} }->{$prt_name}++;
12889
0
0
            $missing_count++ if $new;
12890           }
12891          }
12892         }
12893        }
12894    }
12895
12896    # No longer needed; free some memory.
12897
226
241
    %smaller_prt = ();
12898
12899
226
334
    if ($missing_count) {
12900
12901
0
0
        my $print =
12902          $config{check_transient_supernet_rules} eq 'warn'
12903          ? \&warn_msg
12904          : \&err_msg;
12905
0
0
        $print->("Missing transient rules: $missing_count");
12906
12907
0
0
        while (my ($src_service, $hash) = each %missing_rule_tree) {
12908
0
0
            while (my ($dst_service, $hash) = each %$hash) {
12909
0
0
                while (my ($supernet, $hash) = each %$hash) {
12910
0
0
                    info
12911                      "Rules of $src_service and $dst_service match at $supernet";
12912
0
0
                    info("Missing transient rules:");
12913
0
0
                    while (my ($src, $hash) = each %$hash) {
12914
0
0
                        while (my ($dst, $hash) = each %$hash) {
12915
0
0
                            while (my ($prt, $hash) = each %$hash) {
12916
0
0
                                info(" permit src=$src; dst=$dst; prt=$prt");
12917                            }
12918                        }
12919                    }
12920                }
12921            }
12922        }
12923    }
12924
226
251
    return;
12925}
12926
12927# Handling of supernet rules created by gen_reverse_rules.
12928# This is not needed if a stateful and not secondary packet filter is
12929# located on the path between src and dst.
12930#
12931# 1. dst is supernet
12932#
12933# src--r1:stateful--dst1=supernet1--r2:stateless--dst2=supernet2
12934#
12935# gen_reverse_rule will create one additional rule
12936# supernet2-->src, but not a rule supernet1-->src, because r1 is stateful.
12937# check_supernet_src_rule would complain, that supernet1-->src is missing.
12938# But that doesn't matter, because r1 would permit answer packets
12939# from supernet2 anyway, because it's stateful.
12940# Hence we can skip check_supernet_src_rule for this situation.
12941#
12942# 2. src is supernet
12943#
12944# a) no stateful router on the path between stateless routers and dst.
12945#
12946#             zone2---\
12947# src=supernet1--r1:stateless--dst
12948#
12949# gen_reverse_rules will create one additional rule dst-->supernet1.
12950# check_supernet_dst_rule would complain about a missing rule
12951# dst-->zone2.
12952# To prevent this situation, check_supernet_src_rule checks for a rule
12953# zone2 --> dst
12954#
12955# b) at least one stateful router on the path between
12956#    stateless router and dst.
12957#
12958#               zone3---\
12959# src1=supernet1--r1:stateless--src2=supernet2--r2:stateful--dst
12960#
12961# gen_reverse_rules will create one additional rule
12962# dst-->supernet1, but not dst-->supernet2 because second router is stateful.
12963# check_supernet_dst_rule would complain about missing rules
12964# dst-->supernet2 and dst-->supernet3.
12965# But answer packets back from dst have been filtered by r2 already,
12966# hence it doesn't hurt if the rules at r1 are a bit too relaxed,
12967# i.e. r1 would permit dst to zone1 and zone3, but should only
12968# permit dst to zone1.
12969# Hence we can skip check_supernet_dst_rule for this situation.
12970#
12971
12972# Mark zones connected by stateless or secondary packet filters or by
12973# semi_managed devices.
12974sub mark_stateful {
12975
658
0
584
    my ($zone, $mark) = @_;
12976
658
665
    $zone->{stateful_mark} = $mark;
12977
658
658
497
800
    for my $in_interface (@{ $zone->{interfaces} }) {
12978
887
781
        my $router = $in_interface->{router};
12979
887
1232
        if ($router->{managed}) {
12980            next
12981
850
3007
              if !$router->{model}->{stateless}
12982                  && $router->{managed} !~ /^(?:secondary|local.*)$/;
12983        }
12984
237
434
        next if $router->{active_path};
12985
115
170
        local $router->{active_path} = 1;
12986
115
115
98
146
        for my $out_interface (@{ $router->{interfaces} }) {
12987
260
594
            next if $out_interface eq $in_interface;
12988
145
129
            my $next_zone = $out_interface->{zone};
12989
145
237
            next if $next_zone->{stateful_mark};
12990
116
198
            mark_stateful($next_zone, $mark);
12991        }
12992    }
12993
658
1036
    return;
12994}
12995
12996sub check_supernet_rules {
12997
226
0
403
    if ($config{check_supernet_rules}) {
12998
226
120
226
206
182
300
        my $count = grep { !$_->{deleted} } @{ $expanded_rules{supernet} };
12999
226
514
        progress("Checking $count rules with supernet objects");
13000
226
215
        my $stateful_mark = 1;
13001
226
259
        for my $zone (@zones) {
13002
658
1016
            if (not $zone->{stateful_mark}) {
13003
542
740
                mark_stateful($zone, $stateful_mark++);
13004            }
13005        }
13006
226
226
213
322
        for my $rule (@{ $expanded_rules{supernet} }) {
13007
120
200
            next if $rule->{deleted};
13008
112
162
            next if $rule->{no_check_supernet_rules};
13009
112
200
            if ($rule->{src}->{is_supernet}) {
13010
63
106
                path_walk($rule, \&check_supernet_src_rule);
13011            }
13012
112
228
            if ($rule->{dst}->{is_supernet}) {
13013
56
97
                path_walk($rule, \&collect_supernet_dst_rules);
13014            }
13015        }
13016
226
347
        check_supernet_dst_collections();
13017
226
283
        %missing_supernet = ();
13018    }
13019
226
388
    if ($config{check_transient_supernet_rules}) {
13020
226
302
        check_for_transient_supernet_rule();
13021    }
13022
13023    # no longer needed; free some memory.
13024
226
279
    %obj2zone = ();
13025
226
185
    return;
13026}
13027
13028##############################################################################
13029# Generate reverse rules for stateless packet filters:
13030# For each rule with protocol tcp, udp or ip we need a reverse rule
13031# with swapped src, dst and src-port, dst-port.
13032# For rules with a tcp protocol, the reverse rule gets a tcp protocol
13033# without range checking but with checking for 'established` flag.
13034##############################################################################
13035
13036sub gen_reverse_rules1  {
13037
678
0
577
    my ($rule_aref, $rule_tree) = @_;
13038
678
478
    my @extra_rules;
13039    my %cache;
13040
678
732
    for my $rule (@$rule_aref) {
13041
524
821
        if ($rule->{deleted}) {
13042
21
20
            my $src = $rule->{src};
13043
13044            # If source is a managed interface,
13045            # reversed will get attribute managed_intf.
13046
21
30
            unless (is_interface($src) && ($src->{router}->{managed} ||
13047                                           $src->{router}->{routing_only}))
13048            {
13049
21
33
                next;
13050            }
13051        }
13052
503
455
        my $prt   = $rule->{prt};
13053
503
497
        my $proto = $prt->{proto};
13054
503
1306
        next unless $proto eq 'tcp' or $proto eq 'udp' or $proto eq 'ip';
13055
447
618
        next if $rule->{oneway};
13056
13057        # No reverse rules will be generated for denied TCP packets, because
13058        # - there can't be an answer if the request is already denied and
13059        # - the 'established' optimization for TCP below would produce
13060        #   wrong results.
13061
447
1244
        next if $proto eq 'tcp' and $rule->{deny};
13062
13063
447
377
        my $src = $rule->{src};
13064
447
372
        my $dst = $rule->{dst};
13065
447
948
        my $from_store = $obj2path{$src} || get_path $src;
13066
447
868
        my $to_store   = $obj2path{$dst} || get_path $dst;
13067
447
721
        my $has_stateless_router = $cache{$from_store}->{$to_store};
13068
447
658
        if (!defined $has_stateless_router) {
13069          PATH_WALK:
13070            {
13071
13072                # Local function.
13073                # It uses free variable $has_stateless_router.
13074
287
228
                my $mark_reverse_rule = sub {
13075
433
434
                    my ($rule, $in_intf, $out_intf) = @_;
13076
13077                    # Destination of current rule is current router.
13078                    # Outgoing packets from a router itself are never filtered.
13079                    # Hence we don't need a reverse rule for current router.
13080
433
625
                    return if not $out_intf;
13081
379
363
                    my $router = $out_intf->{router};
13082
13083                    # It doesn't matter if a semi_managed device is stateless
13084                    # because no code is generated.
13085
379
557
                    return if not $router->{managed};
13086
367
347
                    my $model = $router->{model};
13087
13088
367
1170
                    if (
13089                        $model->{stateless}
13090
13091                        # Source of current rule is current router.
13092                        or not $in_intf and $model->{stateless_self}
13093                        )
13094                    {
13095
66
55
                        $has_stateless_router = 1;
13096
13097                        # Jump out of path_walk.
13098
70
70
70
463
100
2482621
                        no warnings "exiting"; ## no critic (ProhibitNoWarn)
13099
66
141
                        last PATH_WALK if $use_nonlocal_exit;
13100                    }
13101
287
839
                };
13102
287
424
                path_walk($rule, $mark_reverse_rule);
13103            }
13104
287
1019
            $cache{$from_store}->{$to_store} = $has_stateless_router || 0;
13105        }
13106
447
938
        if ($has_stateless_router) {
13107
69
116
            my $new_src_range;
13108            my $new_prt;
13109
69
118
            if ($proto eq 'tcp') {
13110
49
56
                $new_prt = $range_tcp_established;
13111            }
13112            elsif ($proto eq 'udp') {
13113
13114                # Swap src and dst range.
13115
13
12
                $new_src_range = $rule->{prt};
13116
13
29
                if ($new_src_range->{range} eq $aref_tcp_any) {
13117
1
1
                    $new_src_range = undef;
13118                }
13119
13
16
                $new_prt = $rule->{src_range};
13120
13
19
                if (not $new_prt) {
13121
5
6
                    $new_prt = $prt_udp->{dst_range};
13122                }
13123            }
13124            elsif ($proto eq 'ip') {
13125
7
5
                $new_prt = $prt;
13126            }
13127            else {
13128
0
0
                internal_err();
13129            }
13130
69
143
            my $new_rule = {
13131
13132                # This rule must only be applied to stateless routers.
13133                stateless => 1,
13134                src       => $dst,
13135                dst       => $src,
13136                prt       => $new_prt,
13137            };
13138
69
107
            $new_rule->{src_range} = $new_src_range if $new_src_range;
13139
69
116
            $new_rule->{deny} = 1 if $rule->{deny};
13140
13141            # Don't push to @$rule_aref while we are iterating over it.
13142
69
143
            push @extra_rules, $new_rule;
13143        }
13144    }
13145
678
629
    push @$rule_aref, @extra_rules;
13146
678
841
    add_rules(\@extra_rules, $rule_tree);
13147
678
1095
    return;
13148}
13149
13150sub gen_reverse_rules {
13151
226
0
299
    progress('Generating reverse rules for stateless routers');
13152
226
183
    my %reverse_rule_tree;
13153
226
271
    for my $type ('deny', 'supernet', 'permit') {
13154
678
1029
        gen_reverse_rules1($expanded_rules{$type}, \%reverse_rule_tree);
13155    }
13156
226
473
    if (keys %reverse_rule_tree) {
13157
38
56
        print_rulecount;
13158
38
51
        progress('Optimizing reverse rules');
13159
38
60
        optimize_rules(\%rule_tree, \%reverse_rule_tree);
13160
38
52
        print_rulecount;
13161    }
13162
13163    # Not longer used, free memory.
13164
226
584
    %rule_tree = ();
13165
226
302
    return;
13166}
13167
13168##############################################################################
13169# Mark rules for secondary filtering.
13170# A rule is implemented at a device
13171# either as a 'typical' or as a 'secondary' filter.
13172# A filter is called to be 'secondary' if it only checks
13173# for the source and destination network and not for the protocol.
13174# A typical filter checks for full source and destination IP and
13175# for the protocol of the rule.
13176#
13177# There are four types of packet filters: secondary, standard, full, primary.
13178# A rule is marked by two attributes which are determined by the type of
13179# devices located on the path from source to destination.
13180# - 'some_primary': at least one device is primary packet filter,
13181# - 'some_non_secondary': at least one device is not secondary packet filter.
13182# A rule is implemented as a secondary filter at a device if
13183# - the device is secondary and the rule has attribute 'some_non_secondary' or
13184# - the device is standard and the rule has attribute 'some_primary'.
13185# Otherwise a rules is implemented typical.
13186##############################################################################
13187
13188sub get_zone2 {
13189
1944
0
1477
    my ($obj) = @_;
13190
1944
1676
    my $type = ref $obj;
13191
1944
3029
    if ($type eq 'Network') {
13192
1202
1427
        return $obj->{zone};
13193    }
13194    elsif ($type eq 'Subnet') {
13195
201
273
        return $obj->{network}->{zone};
13196    }
13197    elsif ($type eq 'Interface') {
13198
541
657
        return $obj->{network}->{zone};
13199    }
13200}
13201
13202# Mark security zone $zone with $mark and
13203# additionally mark all security zones
13204# which are connected with $zone by secondary packet filters.
13205sub mark_secondary;
13206
13207sub mark_secondary  {
13208
658
0
544
    my ($zone, $mark) = @_;
13209
658
667
    $zone->{secondary_mark} = $mark;
13210
13211#    debug("$zone->{name} $mark");
13212
658
658
499
783
    for my $in_interface (@{ $zone->{interfaces} }) {
13213
887
1285
        next if $in_interface->{main_interface};
13214
845
713
        my $router = $in_interface->{router};
13215
845
1280
        if (my $managed = $router->{managed}) {
13216
809
2252
            next if $managed !~ /^(?:secondary|local.*)$/;
13217        }
13218
116
227
        next if $router->{active_path};
13219
54
80
        local $router->{active_path} = 1;
13220
54
54
46
68
        for my $out_interface (@{ $router->{interfaces} }) {
13221
121
280
            next if $out_interface eq $in_interface;
13222
67
101
            next if $out_interface->{main_interface};
13223
64
59
            my $next_zone = $out_interface->{zone};
13224
64
98
            next if $next_zone->{secondary_mark};
13225
62
107
            mark_secondary $next_zone, $mark;
13226        }
13227    }
13228
658
805
    return;
13229}
13230
13231# Mark security zone $zone with $mark and
13232# additionally mark all security zones
13233# which are connected with $zone by non-primary packet filters.
13234# Test for {active_path} has been added to prevent deep recursion.
13235sub mark_primary;
13236
13237sub mark_primary  {
13238
658
0
563
    my ($zone, $mark) = @_;
13239
658
650
    $zone->{primary_mark} = $mark;
13240
658
658
467
786
    for my $in_interface (@{ $zone->{interfaces} }) {
13241
887
1229
        next if $in_interface->{main_interface};
13242
845
724
        my $router = $in_interface->{router};
13243
845
1213
        if (my $managed = $router->{managed}) {
13244
809
1153
            next if $managed eq 'primary';
13245        }
13246
843
1425
        next if $router->{active_path};
13247
412
525
        local $router->{active_path} = 1;
13248
412
412
310
497
        for my $out_interface (@{ $router->{interfaces} }) {
13249
999
1978
            next if $out_interface eq $in_interface;
13250
587
873
            next if $out_interface->{main_interface};
13251
526
460
            my $next_zone = $out_interface->{zone};
13252
526
785
            next if $next_zone->{primary_mark};
13253
419
573
            mark_primary $next_zone, $mark;
13254        }
13255    }
13256
658
1102
    return;
13257}
13258
13259# Mark security zone $zone with $mark and
13260# additionally mark all security zones
13261# which are connected with $zone by non-strict-secondary
13262# packet filters.
13263sub mark_strict_secondary;
13264
13265sub mark_strict_secondary  {
13266
658
0
542
    my ($zone, $mark) = @_;
13267
658
660
    $zone->{strict_secondary_mark} = $mark;
13268#    debug "$zone->{name} : $mark";
13269
658
658
479
774
    for my $in_interface (@{ $zone->{interfaces} }) {
13270
887
1220
        next if $in_interface->{main_interface};
13271
845
703
        my $router = $in_interface->{router};
13272
845
1197
        if ($router->{managed}) {
13273
809
1110
            next if $router->{strict_secondary};
13274        }
13275
845
1399
        next if $router->{active_path};
13276
413
491
        local $router->{active_path} = 1;
13277
413
413
294
477
        for my $out_interface (@{ $router->{interfaces} }) {
13278
1001
1916
            next if $out_interface eq $in_interface;
13279
588
849
            next if $out_interface->{main_interface};
13280
527
456
            my $next_zone = $out_interface->{zone};
13281
527
803
            next if $next_zone->{strict_secondary_mark};
13282
420
537
            mark_strict_secondary($next_zone, $mark);
13283        }
13284    }
13285
658
1040
    return;
13286}
13287
13288# Mark security zone $zone with $mark and additionally mark all
13289# security zones which are connected with $zone by local_secondary
13290# packet filters.
13291sub mark_local_secondary;
13292
13293sub mark_local_secondary  {
13294
658
0
523
    my ($zone, $mark) = @_;
13295
658
660
    $zone->{local_secondary_mark} = $mark;
13296#    debug "local_secondary $zone->{name} : $mark";
13297
658
658
492
750
    for my $in_interface (@{ $zone->{interfaces} }) {
13298
887
1272
        next if $in_interface->{main_interface};
13299
845
670
        my $router = $in_interface->{router};
13300
845
1247
        if (my $managed = $router->{managed}) {
13301
809
1566
            next if $managed ne 'local_secondary';
13302        }
13303
46
92
        next if $router->{active_path};
13304
21
27
        local $router->{active_path} = 1;
13305
21
21
24
31
        for my $out_interface (@{ $router->{interfaces} }) {
13306
47
101
            next if $out_interface eq $in_interface;
13307
26
50
            next if $out_interface->{main_interface};
13308
25
21
            my $next_zone = $out_interface->{zone};
13309
25
44
            next if $next_zone->{local_secondary_mark};
13310
25
47
            mark_local_secondary($next_zone, $mark);
13311        }
13312    }
13313
658
907
    return;
13314}
13315
13316sub mark_secondary_rules {
13317
226
0
306
    progress('Marking rules for secondary optimization');
13318
13319
226
195
    my $secondary_mark        = 1;
13320
226
189
    my $primary_mark          = 1;
13321
226
182
    my $strict_secondary_mark = 1;
13322
226
185
    my $local_secondary_mark  = 1;
13323
226
261
    for my $zone (@zones) {
13324
658
970
        if (not $zone->{secondary_mark}) {
13325
596
824
            mark_secondary $zone, $secondary_mark++;
13326        }
13327
658
1064
        if (not $zone->{primary_mark}) {
13328
239
372
            mark_primary $zone, $primary_mark++;
13329        }
13330
658
995
        if (not $zone->{strict_secondary_mark}) {
13331
238
334
            mark_strict_secondary($zone, $strict_secondary_mark++);
13332        }
13333
658
973
        if (not $zone->{local_secondary_mark}) {
13334
633
817
            mark_local_secondary($zone, $local_secondary_mark++);
13335        }
13336    }
13337
13338    # Mark only normal rules for secondary optimization.
13339    # Don't modify a deny rule from e.g. tcp to ip.
13340    # Don't modify supernet rules, because path isn't fully known.
13341
226
226
226
219
263
306
    for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
13342    {
13343        next
13344
593
955
          if $rule->{deleted}
13345              and
13346              (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13347
13348
560
560
433
669
        my ($src, $dst) = @{$rule}{qw(src dst)};
13349
560
1663
        next if $src->{is_aggregate} || $dst->{is_aggregate};
13350
468
524
        my $src_zone = get_zone2($src);
13351
468
516
        my $dst_zone = get_zone2($dst);
13352
13353
468
1129
        if ($src_zone->{secondary_mark} != $dst_zone->{secondary_mark} ||
13354
13355            # Local secondary optimization.
13356            $src_zone->{local_mark} && $dst_zone->{local_mark} &&
13357            $src_zone->{local_mark} == $dst_zone->{local_mark} &&
13358            $src_zone->{local_secondary_mark} !=
13359            $dst_zone->{local_secondary_mark})
13360        {
13361
359
394
            $rule->{some_non_secondary} = 1;
13362        }
13363
468
758
        if ($src_zone->{primary_mark} != $dst_zone->{primary_mark}) {
13364
1
2
            $rule->{some_primary} = 1;
13365        }
13366
13367        # A device with attribute 'strict_secondary' is located
13368        # between src and dst.
13369        # Each rule must
13370        # - either be optimized secondary
13371        # - or be simple:
13372        #   - protocol IP
13373        #   - src and dst be either
13374        #     - network
13375        #     - loopback interface
13376        #     - interface of managed device
13377
468
966
        if ($src_zone->{strict_secondary_mark} !=
13378            $dst_zone->{strict_secondary_mark})
13379        {
13380
1
3
            if (!$rule->{some_non_secondary}) {
13381
0
0
                my $err;
13382
0
0
                my ($src, $dst, $prt) =
13383
0
0
                    @{$rule}{ qw(src dst prt) };
13384
0
0
                if ($prt ne $prt_ip) {
13385
0
0
                    $err = "'prt = ip'";
13386                }
13387                else {
13388
0
0
                    for my $where (qw(src dst)) {
13389
0
0
                        my $what = $rule->{$where};
13390
0
0
                        if (!is_network($what) &&
13391                            !(is_interface($what) &&
13392                              ($what->{loopback} ||
13393                               $what->{router}->{managed})))
13394                        {
13395
0
0
                            $err =
13396                                "network or managed/loopback interface as "
13397                                . $where;
13398
0
0
                            last;
13399                        }
13400                    }
13401                }
13402
0
0
                if ($err) {
13403
0
0
                    err_msg("Invalid rule at router with attribute",
13404                            " 'strict_secondary'.\n",
13405                            " Rule must only use $err.\n ", print_rule($rule));
13406                }
13407            }
13408        }
13409    }
13410
226
268
    return;
13411}
13412
13413
13414# - Check for partially applied hidden or dynamic NAT on path.
13415# - Check for invalid rules accessing hidden objects.
13416# - Find rules where dynamic NAT is applied to host or interface at
13417#   src or dst on path to other end of rule.
13418#   Mark found rule with attribute {dynamic_nat} and value src|dst|src,dst.
13419sub mark_dynamic_nat_rules {
13420
226
0
289
    progress('Marking rules with dynamic NAT');
13421
13422    # Mapping from nat_tag to boolean.
13423    # Value is true if hidden NAT, false if dynamic NAT.
13424
226
198
    my %dynamic_nat2hidden;
13425
226
253
    for my $network (@networks) {
13426
938
1536
        my $href = $network->{nat} or next;
13427
69
142
        for my $nat_tag (sort keys %$href) {
13428
76
81
            my $nat_network = $href->{$nat_tag};
13429
76
140
            $nat_network->{dynamic} or next;
13430
53
115
            $dynamic_nat2hidden{$nat_tag} = $nat_network->{hidden};
13431        }
13432    }
13433
13434    # Check path for partially applied hidden or dynamic NAT.
13435    my $check_dyn_nat = sub {
13436
61
66
        my ($rule, $in_intf, $out_intf) = @_;
13437
61
99
        my $no_nat_set1 = $in_intf ? $in_intf->{no_nat_set} : undef;
13438
61
75
        my $no_nat_set2 = $out_intf ? $out_intf->{no_nat_set} : undef;
13439
61
93
        for my $nat_tag (keys %dynamic_nat2hidden) {
13440
67
96
            if ($no_nat_set1) {
13441
39
68
                $no_nat_set1->{$nat_tag} or
13442
64
111
                    push @{ $rule->{active_nat_at}->{$nat_tag} }, $in_intf;
13443            }
13444
67
98
            if ($no_nat_set2) {
13445
29
74
                $no_nat_set2->{$nat_tag} or
13446
63
137
                    push @{ $rule->{active_nat_at}->{$nat_tag} }, $out_intf;
13447            }
13448        }
13449
226
766
    };
13450
13451
226
207
    my %cache;
13452
13453
226
226
199
268
    for my $rule (
13454
226
242
        @{ $expanded_rules{permit} },
13455
226
301
        @{ $expanded_rules{supernet} },
13456        @{ $expanded_rules{deny} }
13457      )
13458    {
13459        next
13460
593
942
          if $rule->{deleted}
13461              and
13462              (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13463
13464
560
384
        my $dynamic_nat;
13465
560
509
        for my $where ('src', 'dst') {
13466
1120
991
            my $obj  = $rule->{$where};
13467
1120
946
            my $type = ref $obj;
13468
1120
1330
            my $network =
13469              ($type eq 'Network')
13470              ? $obj
13471              : $obj->{network};
13472
1120
2028
            my $nat_hash = $network->{nat} or next;
13473
77
112
            my $other      = $where eq 'src' ? $rule->{dst} : $rule->{src};
13474
77
70
            my $otype      = ref $other;
13475
77
111
            my $nat_domain = ($otype eq 'Network')
13476              ? $other->{nat_domain}    # Is undef for aggregate.
13477              : $other->{network}->{nat_domain};
13478
77
55
            my $hidden_seen;
13479            my $dynamic_seen;
13480
0
0
            my $static_seen;
13481
13482            # Find $nat_tag which is effective at $other.
13483            # - single: $other is host or network, $nat_domain is known.
13484            # - multiple: $other is aggregate.
13485            #             Check all NAT domains at border of corresponding zone.
13486
77
2
131
3
            for my $no_nat_set (  $nat_domain
13487                                ? ($nat_domain->{no_nat_set})
13488
1
2
                                : map({ $_->{no_nat_set} }
13489                                      @{ $other->{zone}->{interfaces} }))
13490            {
13491
78
66
                my $nat_found;
13492
78
126
                for my $nat_tag (sort keys %$nat_hash) {
13493
78
135
                    next if $no_nat_set->{$nat_tag};
13494
64
54
                    $nat_found = 1;
13495
64
62
                    my $nat_network = $nat_hash->{$nat_tag};
13496
13497                    # Network is hidden by NAT.
13498
64
104
                    if ($nat_network->{hidden}) {
13499
3
13
                        $hidden_seen++ or
13500                            err_msg("$obj->{name} is hidden by nat:$nat_tag",
13501                                    " in rule\n ",
13502                                    print_rule $rule);
13503
3
6
                        next;
13504                    }
13505
61
91
                    if (!$nat_network->{dynamic}) {
13506
13
9
                        $static_seen = 1;
13507
13
20
                        next;
13508                    }
13509
13510                    # Network has dynamic NAT.
13511
48
66
                    $dynamic_seen and next;
13512
48
159
                    $type eq 'Subnet' or $type eq 'Interface' or next;
13513
13514                    # Host / interface doesn't have static NAT.
13515
24
57
                    $obj->{nat}->{$nat_tag} and next;
13516
13517                    # Check error condition: Dynamic NAT address is
13518                    # used in ACL at managed router at the border of
13519                    # zone of $obj.
13520                    # $intf could have value 'undef' if $obj is interface of
13521                    # current router and destination of rule.
13522                    my $check = sub {
13523
10
10
                        my ($rule, $in_intf, $out_intf) = @_;
13524
10
11
                        my $no_nat_set = $in_intf->{no_nat_set};
13525
10
11
                        my $nat_network =
13526                            get_nat_network($network, $no_nat_set);
13527
10
12
                        my $nat_tag = $nat_network->{dynamic};
13528
10
15
                        return if not $nat_tag;
13529
7
13
                        return if $obj->{nat}->{$nat_tag};
13530
7
10
                        my $intf = $where eq 'src' ? $in_intf : $out_intf;
13531
7
19
                        if (!$intf ||
13532                            zone_eq($network->{zone}, $intf->{zone}))
13533                        {
13534
5
19
                            err_msg "$obj->{name} needs static translation",
13535                                " for nat:$nat_tag to be valid in rule\n ",
13536                            print_rule $rule;
13537                        }
13538
7
28
                    };
13539
7
8
                    path_walk($rule, $check);
13540
13541
7
8
                    $dynamic_nat =
13542                      $dynamic_nat
13543                      ? "$dynamic_nat,$where"
13544                      : $where;
13545
13546#                   debug("dynamic_nat: $where at ", print_rule $rule);
13547
7
34
                    $dynamic_seen = 1;
13548                }
13549
78
166
                $nat_found or $static_seen = 1;
13550            }
13551
13552
77
109
            $hidden_seen and next;
13553
13554            # Check error conditition:
13555            # Find sub-path where dynamic / hidden NAT is enabled,
13556            # i.e. dynamic / hidden NAT is enabled first and disabled later.
13557
13558            # Find dynamic and hidden NAT definitions of $obj.
13559            # Key: NAT tag,
13560            # value: boolean, true=hidden, false=dynamic
13561
74
61
            my $dyn_nat_hash;
13562
74
108
            for my $nat_tag (keys %$nat_hash) {
13563
74
77
                my $nat_network = $nat_hash->{$nat_tag};
13564
74
118
                $nat_network->{dynamic} or next;
13565
60
118
                $dyn_nat_hash->{$nat_tag} = $nat_network->{hidden};
13566            }
13567
74
133
            $dyn_nat_hash or next;
13568
13569
54
115
            my $from_store = $obj2path{$obj} || get_path $obj;
13570
54
100
            my $to_store   = $obj2path{$other} || get_path $other;
13571
54
191
            my $active_nat_at =
13572                $cache{$from_store}->{$to_store} ||
13573                $cache{$to_store}->{$from_store};
13574
13575
54
75
            if (!$active_nat_at) {
13576
35
80
                $cache{$from_store}->{$to_store} =
13577                    $active_nat_at = $rule->{active_nat_at} = {};
13578
35
61
                path_walk($rule, $check_dyn_nat);
13579
35
51
                delete $rule->{active_nat_at};
13580            }
13581
13582
54
121
            for my $nat_tag (sort keys %$dyn_nat_hash) {
13583
60
127
                my $interfaces = $active_nat_at->{$nat_tag} or next;
13584
53
46
                my $is_hidden = $dyn_nat_hash->{$nat_tag};
13585
53
251
                ($is_hidden || $static_seen) or next;
13586
12
24
                my $names =
13587
5
10
                    join("\n - ", map({ $_->{name} } sort(by_name @$interfaces)));
13588
5
10
                my $type = $is_hidden ? 'hidden' : 'dynamic';
13589
5
17
                err_msg("Must not apply $type NAT '$nat_tag' on path\n",
13590                        " of", $where eq 'dst' ? ' reversed' : '', " rule\n",
13591                        " ", print_rule($rule), "\n",
13592                        " NAT '$nat_tag' is active at\n",
13593                        " - $names\n",
13594                        " Add pathrestriction",
13595                        " to exclude this path");
13596            }
13597        }
13598
560
966
        $rule->{dynamic_nat} = $dynamic_nat if $dynamic_nat;
13599    }
13600
226
1104
    return;
13601}
13602
13603##############################################################################
13604# Optimize expanded rules by deleting identical rules and
13605# rules which are overlapped by a more general rule
13606##############################################################################
13607
13608sub optimize_rules {
13609
264
0
264
my ($cmp_hash, $chg_hash) = @_;
13610
264
652
while (my ($stateless, $chg_hash) = each %$chg_hash) {
13611
230
183
  while (1) {
13612
268
455
   if (my $cmp_hash = $cmp_hash->{$stateless}) {
13613
230
532
    while (my ($deny, $chg_hash) = each %$chg_hash) {
13614
230
175
     while (1) {
13615
460
751
      if (my $cmp_hash = $cmp_hash->{$deny}) {
13616
230
520
       while (my ($src_range_ref, $chg_hash) = each %$chg_hash) {
13617
256
236
        my $src_range = $ref2prt{$src_range_ref};
13618
256
195
        while (1) {
13619
322
608
         if (my $cmp_hash = $cmp_hash->{$src_range}) {
13620
280
570
          while (my ($src_ref, $chg_hash) = each %$chg_hash) {
13621
475
428
           my $src = $ref2obj{$src_ref};
13622
475
680
           while (1) {
13623
785
1391
            if (my $cmp_hash = $cmp_hash->{$src}) {
13624
462
889
             while (my ($dst_ref, $chg_hash) = each %$chg_hash) {
13625
591
854
              my $dst = $ref2obj{$dst_ref};
13626
591
449
              while (1) {
13627
966
1683
               if (my $cmp_hash = $cmp_hash->{$dst}) {
13628
595
1165
                for my $chg_rule (values %$chg_hash) {
13629
13630                 # Even if $change_rule already is marked as deleted,
13631                 # don't stop here, but go on and find all redundant
13632                 # pairs of ($change_rule, $cmp_rule).
13633                 # This is needed, because some instances of $cmp_rule
13634                 # may have an {overlaps} attribute, which prevents
13635                 # a warning message to be printed.
13636
627
562
                 my $prt = $chg_rule->{prt};
13637
627
1510
                 my $chg_log = $chg_rule->{log} || '';
13638
627
454
                 while (1) {
13639
1703
2743
                  if (my $cmp_rule = $cmp_hash->{$prt}) {
13640
556
1246
                   my $cmp_log = $cmp_rule->{log} || '';
13641
556
2294
                   if ($cmp_rule ne $chg_rule && $cmp_log eq $chg_log) {
13642#                   debug("Del:", print_rule $chg_rule);
13643#                   debug("Oth:", print_rule $cmp_rule);
13644
32
34
                    $chg_rule->{deleted} = $cmp_rule;
13645
32
107
                    collect_redundant_rules($chg_rule, $cmp_rule);
13646
32
64
                    last;
13647                   }
13648                  }
13649
1671
3011
                  $prt = $prt->{up} or last;
13650                 }
13651                }
13652               }
13653
966
2348
               $dst = $dst->{up} or last;
13654              }
13655             }
13656            }
13657
785
1767
            $src = $src->{up} or last;
13658           }
13659          }
13660         }
13661
322
826
         $src_range = $src_range->{up} or last;
13662        }
13663       }
13664      }
13665
460
886
      last if $deny;
13666
230
226
      $deny = 1;
13667     }
13668    }
13669   }
13670
268
646
   last if !$stateless;
13671
38
44
   $stateless = '';
13672  }
13673 }
13674
264
264
return;
13675}
13676
13677sub optimize_and_warn_deleted {
13678
226
0
631
    progress('Optimizing globally');
13679
226
330
    setup_ref2obj();
13680
226
423
    optimize_rules(\%rule_tree, \%rule_tree);
13681
226
332
    print_rulecount();
13682
226
313
    show_deleted_rules2();
13683
226
323
    warn_unused_overlaps();
13684
226
184
    return;
13685}
13686
13687########################################################################
13688# Prepare NAT commands
13689########################################################################
13690
13691# Collect devices which need NAT commands.
13692sub collect_nat_path {
13693
387
0
364
    my ($rule, $in_intf, $out_intf) = @_;
13694
13695    # No NAT needed for directly attached interface.
13696
387
564
    return unless $out_intf;
13697
13698    # No NAT needed for traffic originating from the device itself.
13699
324
453
    return unless $in_intf;
13700
13701
293
276
    my $router = $out_intf->{router};
13702
293
456
    return unless $router->{managed};
13703
279
247
    my $model = $router->{model};
13704
279
523
    return unless $model->{has_interface_level};
13705
13706
122
122
103
271
    push @{ $rule->{nat_path} }, [ $in_intf, $out_intf ];
13707
122
160
    return;
13708}
13709
13710# Distribute networks needing NAT commands to device.
13711sub distribute_nat_to_device {
13712
122
0
109
    my ($pair, $src_net, $dst_net) = @_;
13713
122
129
    my ($in_intf, $out_intf) = @$pair;
13714
122
112
    my $router = $out_intf->{router};
13715
122
115
    my $model = $router->{model};
13716
13717    # We need in_hw and out_hw for
13718    # - attaching attribute src_nat and
13719    # - getting the NAT tag.
13720
122
107
    my $in_hw  = $in_intf->{hardware};
13721
122
103
    my $out_hw = $out_intf->{hardware};
13722
13723
122
130
    my $identity_nat = $model->{need_identity_nat};
13724
122
281
    if ($identity_nat) {
13725
13726        # Static dst NAT is equivalent to reversed src NAT.
13727
1
1
        for my $dst (@$dst_net) {
13728
1
4
            $out_hw->{src_nat}->{$in_hw}->{$dst} = $dst;
13729        }
13730
1
3
        if ($in_hw->{level} > $out_hw->{level}) {
13731
0
0
            $in_hw->{need_nat_0} = 1;
13732        }
13733    }
13734
13735    # Not identity NAT, handle real dst NAT.
13736    elsif (my $nat_tags = $in_hw->{bind_nat}) {
13737
11
13
        for my $dst (@$dst_net) {
13738
11
16
            my $nat_info = $dst->{nat} or next;
13739
11
11
19
25
            grep({ $nat_info->{$_} } @$nat_tags) or next;
13740
13741            # Store reversed dst NAT for real translation.
13742
11
39
            $out_hw->{src_nat}->{$in_hw}->{$dst} = $dst;
13743        }
13744    }
13745
13746    # Handle real src NAT.
13747    # Remember:
13748    # NAT tag for network located behind in_hw is attached to out_hw.
13749
122
1393
    my $nat_tags = $out_hw->{bind_nat} or return;
13750
14
15
    for my $src (@$src_net) {
13751
17
36
        my $nat_info = $src->{nat} or next;
13752
13753        # We can be sure to get a single result.
13754        # Binding for different NAT of a single network has been
13755        # rejected in distribute_nat_info.
13756
11
11
13
42
        my ($nat_net) = map({ $nat_info->{$_} || () } @$nat_tags) or next;
13757
13758        # Store src NAT for real translation.
13759
11
28
        $in_hw->{src_nat}->{$out_hw}->{$src} = $src;
13760
13761
11
29
        if ($identity_nat) {
13762
13763            # Check if there is a dynamic NAT of src address from lower
13764            # to higher security level. We need this info to decide,
13765            # if static commands with "identity mapping" and a "nat 0" command
13766            # need to be generated.
13767
0
0
            if ($nat_net->{dynamic} and $in_hw->{level} < $out_hw->{level}) {
13768
0
0
                $in_hw->{need_identity_nat} = 1;
13769
0
0
                $in_hw->{need_nat_0}        = 1;
13770            }
13771        }
13772    }
13773
14
44
    return;
13774}
13775
13776sub get_zone3 {
13777
480
0
403
    my ($obj) = @_;
13778
480
458
    my $type = ref $obj;
13779
480
772
    if ($type eq 'Network') {
13780
320
736
        return $obj->{zone};
13781    }
13782    elsif ($type eq 'Subnet') {
13783
44
114
        return $obj->{network}->{zone};
13784    }
13785    elsif ($type eq 'Interface') {
13786
116
114
        my $router = $obj->{router};
13787
116
283
        if ($router->{managed} or $router->{semi_managed}) {
13788
64
145
            return $obj;
13789        }
13790        else {
13791
52
123
            return $obj->{network}->{zone};
13792        }
13793    }
13794    else {
13795
0
0
        internal_err();
13796    }
13797}
13798
13799sub get_networks {
13800
217
0
192
    my ($obj) = @_;
13801
217
208
    my $type = ref $obj;
13802
217
445
    if ($type eq 'Network') {
13803
132
191
        if ($obj->{is_aggregate}) {
13804
17
40
            return $obj->{networks};
13805        }
13806        else {
13807
115
299
            return [ $obj ];
13808        }
13809    }
13810    elsif ($type eq 'Subnet' or $type eq 'Interface') {
13811
85
237
        return [ $obj->{network} ];
13812    }
13813    else {
13814
0
0
        internal_err("unexpected $obj->{name}");
13815    }
13816}
13817
13818sub prepare_nat_commands  {
13819
226
0
274
    return if fast_mode();
13820
155
221
    progress('Preparing NAT commands');
13821
13822    # Caching for performance.
13823
155
125
    my %obj2zone;
13824    my %obj2networks;
13825
13826    # Traverse the topology once for each pair of
13827    # src-(zone/router), dst-(zone/router)
13828
0
0
    my %zone2zone2info;
13829
155
155
155
136
184
223
    for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
13830    {
13831        next
13832
414
661
          if $rule->{deleted}
13833              and
13834              (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13835
409
409
335
486
        my ($src, $dst) = @{$rule}{qw(src dst)};
13836
409
997
        my $from = $obj2zone{$src} ||= get_zone3($src);
13837
409
907
        my $to   = $obj2zone{$dst} ||= get_zone3($dst);
13838
409
700
        my $info = $zone2zone2info{$from}->{$to};
13839
409
569
        if (!$info) {
13840
244
435
            path_walk($rule, \&collect_nat_path, 'Router');
13841
244
434
            $info->{nat_path} = delete $rule->{nat_path};
13842
244
493
            $zone2zone2info{$from}->{$to} = $info;
13843        }
13844
13845        # Collect networks only if path has some NAT device.
13846
409
808
        if ($info->{nat_path}) {
13847
177
459
            my $src_networks = $obj2networks{$src} ||= get_networks($src);
13848
177
177
183
339
            @{$info->{src_net}}{@$src_networks} = @$src_networks;
13849
177
418
            my $dst_networks = $obj2networks{$dst} ||= get_networks($dst);
13850
177
177
161
524
            @{$info->{dst_net}}{@$dst_networks} = @$dst_networks;
13851        }
13852    }
13853
155
269
    for my $hash (values %zone2zone2info) {
13854
196
307
        for my $info (values %$hash) {
13855
244
529
            my $nat_path = $info->{nat_path} or next;
13856
99
99
87
186
            my $src_net = [ values %{ $info->{src_net} } ];
13857
99
99
93
166
            my $dst_net = [ values %{ $info->{dst_net} } ];
13858
99
133
            for my $pair (@$nat_path) {
13859
122
175
                distribute_nat_to_device($pair, $src_net, $dst_net);
13860            }
13861        }
13862    }
13863
155
568
    return;
13864}
13865
13866########################################################################
13867# Routing
13868########################################################################
13869
13870# Get networks for routing.
13871# Add largest supernet inside the zone, if available.
13872# This is needed, because we use the supernet in
13873# secondary optimization too.
13874# Moreover this reduces the number of routing entries.
13875# It isn't sufficient to solely use the supernet because network and supernet
13876# can have different next hops at end of path.
13877# For an aggregate, take all matching networks inside the zone.
13878# These are supernets by design.
13879
13880sub get_route_networks {
13881
927
0
731
    my ($obj) = @_;
13882
927
818
    my $type = ref $obj;
13883
927
1644
    if ($type eq 'Network') {
13884
640
1103
        if ($obj->{is_aggregate}) {
13885
82
82
63
158
            return @{ $obj->{networks} };
13886        }
13887        elsif (my $max = $obj->{max_routing_net}) {
13888
11
23
            return ($max, $obj);
13889        }
13890        else {
13891
547
754
            return $obj;
13892        }
13893    }
13894    elsif ($type eq 'Subnet' or $type eq 'Interface') {
13895
287
270
        my $net = $obj->{network};
13896
287
379
        if (my $max = $net->{max_routing_net}) {
13897
28
56
            return ($max, $net);
13898        }
13899        else {
13900
259
402
            return $net;
13901        }
13902    }
13903    else {
13904
0
0
        internal_err("unexpected $obj->{name}");
13905    }
13906}
13907
13908# Set up data structure to find routing info inside a security zone.
13909# Some definitions:
13910# - Border interfaces are directly attached to the security zone.
13911# - Border networks are located inside the security zone and are attached
13912#   to border interfaces.
13913# - All interfaces of border networks, which are not border interfaces,
13914#   are called hop interfaces, because they are used as next hop from
13915#   border interfaces.
13916# - A cluster is a maximal set of connected networks of the security zone,
13917#   which is surrounded by hop interfaces. A cluster can be empty.
13918# For each border interface I and each network N inside the security zone
13919# we need to find the hop interface H via which N is reached from I.
13920# This is stored in an attribute {route_in_zone} of I.
13921sub set_routes_in_zone  {
13922
658
0
561
    my ($zone) = @_;
13923
13924    # Mark border networks and hop interfaces.
13925
658
452
    my %border_networks;
13926    my %hop_interfaces;
13927
658
658
502
811
    for my $in_interface (@{ $zone->{interfaces} }) {
13928
887
1276
        next if $in_interface->{main_interface};
13929
845
730
        my $network = $in_interface->{network};
13930
845
1949
        next if $border_networks{$network};
13931
670
886
        $border_networks{$network} = $network;
13932
670
670
496
766
        for my $out_interface (@{ $network->{interfaces} }) {
13933
1006
2248
            next if $out_interface->{zone};
13934
119
183
            next if $out_interface->{main_interface};
13935
117
242
            $hop_interfaces{$out_interface} = $out_interface;
13936        }
13937    }
13938
658
1602
    return if not keys %hop_interfaces;
13939
93
75
    my %hop2cluster;
13940    my %cluster2borders;
13941
0
0
    my $set_cluster;
13942    $set_cluster = sub {
13943
131
129
        my ($router, $in_intf, $cluster) = @_;
13944
131
218
        return if $router->{active_path};
13945
124
163
        local $router->{active_path} = 1;
13946
124
124
96
170
        for my $interface (@{ $router->{interfaces} }) {
13947
307
449
            next if $interface->{main_interface};
13948
295
517
            if ($hop_interfaces{$interface}) {
13949
117
177
                $hop2cluster{$interface} = $cluster;
13950
117
111
                my $network = $interface->{network};
13951
117
246
                $cluster2borders{$cluster}->{$network} = $network;
13952
117
248
                next;
13953            }
13954
178
384
            next if $interface eq $in_intf;
13955
150
138
            my $network = $interface->{network};
13956
150
242
            next if $cluster->{$network};
13957
143
191
            $cluster->{$network} = $network;
13958
143
143
113
175
            for my $out_intf (@{ $network->{interfaces} }) {
13959
188
524
                next if $out_intf eq $interface;
13960
45
71
                next if $out_intf->{main_interface};
13961
35
96
                $set_cluster->($out_intf->{router}, $out_intf, $cluster);
13962            }
13963        }
13964
93
328
    };
13965
93
140
    for my $interface (values %hop_interfaces) {
13966
117
234
        next if $hop2cluster{$interface};
13967
96
98
        my $cluster = {};
13968
96
159
        $set_cluster->($interface->{router}, $interface, $cluster);
13969
13970#       debug("Cluster: $interface->{name} ",
13971#             join ',', map {$_->{name}} values %$cluster);
13972    }
13973
13974    # Find all networks located behind a hop interface.
13975
93
90
    my %hop2networks;
13976    my $set_networks_behind;
13977    $set_networks_behind = sub {
13978
124
130
        my ($hop, $in_border) = @_;
13979
124
222
        return if $hop2networks{$hop};
13980
117
149
        my $cluster = $hop2cluster{$hop};
13981
13982        # Add networks of directly attached cluster to result.
13983
117
198
        my @result = values %$cluster;
13984
117
185
        $hop2networks{$hop} = \@result;
13985
13986
117
117
106
231
        for my $border (values %{ $cluster2borders{$cluster} }) {
13987
155
384
            next if $border eq $in_border;
13988
13989            # Add other border networks to result.
13990
38
49
            push @result, $border;
13991
38
38
33
46
            for my $out_hop (@{ $border->{interfaces} }) {
13992
83
169
                next if not $hop_interfaces{$out_hop};
13993
45
175
                next if $hop2cluster{$out_hop} eq $cluster;
13994
7
13
                $set_networks_behind->($out_hop, $border);
13995
13996                # Add networks from clusters located behind
13997                # other border networks.
13998
7
7
6
16
                push @result, @{ $hop2networks{$out_hop} };
13999            }
14000        }
14001
117
177
        $hop2networks{$hop} = [ unique @result];
14002#       debug("Hop: $hop->{name} ", join ',', map {$_->{name}} @result);
14003
93
321
    };
14004
93
134
    for my $border (values %border_networks) {
14005
111
96
        my @border_intf;
14006        my @hop_intf;
14007
111
111
92
142
        for my $interface (@{ $border->{interfaces} }) {
14008
233
346
            next if $interface->{main_interface};
14009
231
293
            if ($interface->{zone}) {
14010
114
149
                push @border_intf, $interface;
14011            }
14012            else {
14013
117
162
                push @hop_intf, $interface;
14014            }
14015        }
14016
111
124
        for my $hop (@hop_intf) {
14017
117
154
            $set_networks_behind->($hop, $border);
14018
117
147
            for my $interface (@border_intf) {
14019
120
120
99
197
                for my $network (@{ $hop2networks{$hop} }) {
14020
14021                    # $border will be found accidently, if clusters
14022                    # form a loop inside zone.
14023
205
369
                    next if $network eq $border;
14024
201
201
156
710
                    push @{ $interface->{route_in_zone}->{$network} }, $hop;
14025                }
14026            }
14027        }
14028    }
14029
93
212
    return;
14030}
14031
14032# A security zone is entered at $in_intf and exited at $out_intf.
14033# Find the hop H to reach $out_intf from $in_intf.
14034# Add routing entries at $in_intf that $dst_networks are reachable via H.
14035sub add_path_routes  {
14036
245
0
228
    my ($in_intf, $out_intf, $dst_networks) = @_;
14037
245
439
    return if $in_intf->{routing};
14038
149
153
    my $out_net = $out_intf->{network};
14039
149
497
    my $hops = $in_intf->{route_in_zone}->{$out_net} || [$out_intf];
14040
149
175
    for my $hop (@$hops) {
14041
151
253
        $in_intf->{hop}->{$hop} = $hop;
14042
151
155
        for my $network (@$dst_networks) {
14043
14044#           debug("$in_intf->{name} -> $hop->{name}: $network->{name}");
14045
155
514
            $in_intf->{routes}->{$hop}->{$network} = $network;
14046        }
14047    }
14048
149
250
    return;
14049}
14050
14051# A security zone is entered at $interface.
14052# $dst_networks are located inside the security zone.
14053# For each element N of $dst_networks find the next hop H to reach N.
14054# Add routing entries at $interface that N is reachable via H.
14055sub add_end_routes  {
14056
648
0
554
    my ($interface, $dst_networks) = @_;
14057
648
1231
    return if $interface->{routing};
14058
481
442
    my $intf_net      = $interface->{network};
14059
481
394
    my $route_in_zone = $interface->{route_in_zone};
14060
481
471
    for my $network (@$dst_networks) {
14061
542
1273
        next if $network eq $intf_net;
14062
186
395
        my $hops = $route_in_zone->{$network}
14063          or internal_err("Missing route for $network->{name}",
14064                          " at $interface->{name}");
14065
186
172
        for my $hop (@$hops) {
14066
192
309
            $interface->{hop}->{$hop} = $hop;
14067
14068#           debug("$interface->{name} -> $hop->{name}: $network->{name}");
14069
192
593
            $interface->{routes}->{$hop}->{$network} = $network;
14070        }
14071    }
14072
481
1006
    return;
14073}
14074
14075# This function is called for each zone on the path from src to dst
14076# of $rule.
14077# If $in_intf and $out_intf are both defined, packets traverse this zone.
14078# If $in_intf is not defined, the src is this zone.
14079# If $out_intf is not defined, dst is this zone;
14080sub get_route_path {
14081
645
0
578
    my ($rule, $in_intf, $out_intf) = @_;
14082
14083#    debug("collect: $rule->{src}->{name} -> $rule->{dst}->{name}");
14084#    my $info = '';
14085#    $info .= $in_intf->{name} if $in_intf;
14086#    $info .= ' -> ';
14087#    $info .= $out_intf->{name} if $out_intf;
14088#    debug($info);
14089
14090
645
1699
    if ($in_intf and $out_intf) {
14091
112
112
78
243
        push @{ $rule->{path} }, [ $in_intf, $out_intf ];
14092    }
14093    elsif (not $in_intf) {
14094
266
266
206
490
        push @{ $rule->{path_entries} }, $out_intf;
14095    }
14096    else {
14097
267
267
206
466
        push @{ $rule->{path_exits} }, $in_intf;
14098    }
14099
645
728
    return;
14100}
14101
14102sub check_and_convert_routes;
14103
14104sub find_active_routes  {
14105
226
0
311
    progress('Finding routes');
14106
226
254
    for my $zone (@zones) {
14107
658
798
        set_routes_in_zone $zone;
14108    }
14109
226
208
    my %routing_tree;
14110
226
382
    my $pseudo_prt = { name => '--' };
14111
226
226
226
205
268
311
    for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
14112    {
14113
524
643
        my ($src, $dst) = ($rule->{src}, $rule->{dst});
14114
14115        # Ignore deleted rules.
14116        # Add the typical check for {managed_intf}
14117        # which covers the destination interface.
14118        # Because we handle both directions at once,
14119        # we would need an attribute {managed_intf}
14120        # for the source interface as well. But this attribute doesn't exist
14121        # and we add an equivalent check for source.
14122
524
938
        if (
14123                $rule->{deleted}
14124            and (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf})
14125            and (
14126                not(is_interface $src and ($src->{router}->{managed} or
14127                                           $src->{router}->{routing_only}))
14128                or (is_interface $rule->{deleted}->{src}
14129                    and ($rule->{deleted}->{src}->{router}->{managed} or
14130                         $rule->{deleted}->{src}->{router}->{routing_only}))
14131            )
14132          )
14133        {
14134
20
26
            next;
14135        }
14136
504
626
        my $src_zone = get_zone2 $src;
14137
504
575
        my $dst_zone = get_zone2 $dst;
14138
14139        # Source interface is located in security zone of destination or
14140        # destination interface is located in security zone of source.
14141        # path_walk will do nothing.
14142
504
1025
        if ($src_zone eq $dst_zone) {
14143
98
105
            for my $from ($src, $dst) {
14144
196
325
                my $to = $from eq $src ? $dst : $src;
14145
196
220
                next if not is_interface($from);
14146
170
311
                next if not $from->{zone};
14147
115
313
                $from = $from->{main_interface} || $from;
14148
115
143
                my @networks = get_route_networks($to);
14149
115
146
                add_end_routes($from, \@networks);
14150            }
14151
98
138
            next;
14152        }
14153
406
297
        my $pseudo_rule;
14154
406
1182
        if ($pseudo_rule = $routing_tree{$src_zone}->{$dst_zone}) {
14155        }
14156        elsif ($pseudo_rule = $routing_tree{$dst_zone}->{$src_zone}) {
14157
13
22
            ($src,      $dst)      = ($dst,      $src);
14158
13
17
            ($src_zone, $dst_zone) = ($dst_zone, $src_zone);
14159        }
14160        else {
14161
246
491
            $pseudo_rule = {
14162                src    => $src_zone,
14163                dst    => $dst_zone,
14164                prt    => $pseudo_prt,
14165            };
14166
246
476
            $routing_tree{$src_zone}->{$dst_zone} = $pseudo_rule;
14167        }
14168
406
511
        my @src_networks = get_route_networks($src);
14169
406
449
        for my $network (@src_networks) {
14170
419
1005
            $pseudo_rule->{src_networks}->{$network} = $network;
14171        }
14172
406
495
        my @dst_networks = get_route_networks($dst);
14173
406
439
        for my $network (@dst_networks) {
14174
413
951
            $pseudo_rule->{dst_networks}->{$network} = $network;
14175        }
14176
406
522
        if (is_interface($src) && ($src->{router}->{managed} ||
14177                                   $src->{router}->{routing_only}))
14178        {
14179
17
52
            $src = $src->{main_interface} || $src;
14180
17
32
            $pseudo_rule->{src_interfaces}->{$src} = $src;
14181
17
22
            for my $network (@dst_networks) {
14182
17
49
                $pseudo_rule->{src_intf2nets}->{$src}->{$network} = $network;
14183            }
14184        }
14185
406
496
        if (is_interface($dst) && ($dst->{router}->{managed} ||
14186                                   $dst->{router}->{routing_only}))
14187        {
14188
37
141
            $dst = $dst->{main_interface} || $dst;
14189
37
73
            $pseudo_rule->{dst_interfaces}->{$dst} = $dst;
14190
37
43
            for my $network (@src_networks) {
14191
36
165
                $pseudo_rule->{dst_intf2nets}->{$dst}->{$network} = $network;
14192            }
14193        }
14194    }
14195
226
382
    for my $href (values %routing_tree) {
14196
426
745
        for my $pseudo_rule (values %$href) {
14197
246
410
            path_walk($pseudo_rule, \&get_route_path, 'Zone');
14198
246
246
212
498
            my $src_networks   = [ values %{ $pseudo_rule->{src_networks} } ];
14199
246
246
218
423
            my $dst_networks   = [ values %{ $pseudo_rule->{dst_networks} } ];
14200
246
246
204
489
            my @src_interfaces = values %{ $pseudo_rule->{src_interfaces} };
14201
246
246
195
372
            my @dst_interfaces = values %{ $pseudo_rule->{dst_interfaces} };
14202
246
246
195
389
            for my $tuple (@{ $pseudo_rule->{path} }) {
14203
112
116
                my ($in_intf, $out_intf) = @$tuple;
14204
112
157
                add_path_routes($in_intf,  $out_intf, $dst_networks);
14205
112
184
                add_path_routes($out_intf, $in_intf,  $src_networks);
14206            }
14207
246
246
222
304
            for my $entry (@{ $pseudo_rule->{path_entries} }) {
14208
266
284
                for my $src_intf (@src_interfaces) {
14209
19
57
                    next if $src_intf->{router} eq $entry->{router};
14210
8
17
                    if (my $redun_intf = $src_intf->{redundancy_interfaces}) {
14211
0
0
0
0
                        if (grep { $_->{router} eq $entry->{router} }
14212                            @$redun_intf)
14213                        {
14214
0
0
                            next;
14215                        }
14216                    }
14217
8
28
                    my $intf_nets = [
14218
8
6
                        values %{ $pseudo_rule->{src_intf2nets}->{$src_intf} }
14219                    ];
14220
8
12
                    add_path_routes($src_intf, $entry, $intf_nets);
14221                }
14222
266
366
                add_end_routes($entry, $src_networks);
14223            }
14224
246
246
225
339
            for my $exit (@{ $pseudo_rule->{path_exits} }) {
14225
267
278
                for my $dst_intf (@dst_interfaces) {
14226
45
130
                    next if $dst_intf->{router} eq $exit->{router};
14227
19
41
                    if (my $redun_intf = $dst_intf->{redundancy_interfaces}) {
14228
6
12
7
31
                        if (grep { $_->{router} eq $exit->{router} }
14229                            @$redun_intf)
14230                        {
14231
6
9
                            next;
14232                        }
14233                    }
14234
13
35
                    my $intf_nets = [
14235
13
13
                        values %{ $pseudo_rule->{dst_intf2nets}->{$dst_intf} }
14236                    ];
14237
13
23
                    add_path_routes($dst_intf, $exit, $intf_nets);
14238                }
14239
267
303
                add_end_routes($exit, $dst_networks);
14240            }
14241        }
14242    }
14243
226
343
    check_and_convert_routes;
14244
226
954
    return;
14245}
14246
14247# Parameters:
14248# - a bridged interface without an IP address, not usable as hop.
14249# - the network for which the hop was found.
14250# Result:
14251# - one or more layer 3 interfaces, usable as hop.
14252# Non optimized version.
14253# Doesn't matter as long we have only a few bridged networks
14254# or don't use static routing at the border of bridged networks.
14255sub fix_bridged_hops;
14256
14257sub fix_bridged_hops {
14258
2
0
2
    my ($hop, $network) = @_;
14259
2
2
    my @result;
14260
2
3
    my $router = $hop->{router};
14261
2
2
2
2
    for my $interface (@{ $router->{interfaces} }) {
14262
6
12
        next if $interface eq $hop;
14263
4
17
      HOP:
14264
4
3
        for my $hop2 (values %{ $interface->{hop} }) {
14265
1
1
1
3
            for my $network2 (values %{ $interface->{routes}->{$hop2} }) {
14266
1
3
                if ($network eq $network2) {
14267
1
3
                    if ($hop2->{ip} eq 'bridge') {
14268
0
0
                        push @result, fix_bridged_hops($hop2, $network);
14269                    }
14270                    else {
14271
1
1
                        push @result, $hop2;
14272                    }
14273
1
3
                    next HOP;
14274                }
14275            }
14276        }
14277    }
14278
2
7
    return @result;
14279}
14280
14281sub check_and_convert_routes  {
14282
226
0
286
    progress('Checking for duplicate routes');
14283
14284    # Fix routes to bridged interfaces without IP address.
14285
226
268
    for my $router (@managed_routers, @routing_only_routers) {
14286
365
365
290
459
        for my $interface (@{ $router->{interfaces} }) {
14287
862
1731
            next if not $interface->{network}->{bridged};
14288
16
16
11
35
            for my $hop (values %{ $interface->{hop} }) {
14289
8
20
                next if $hop->{ip} ne 'bridged';
14290
2
2
3
6
                for my $network (values %{ $interface->{routes}->{$hop} }) {
14291
2
3
                    my @real_hop = fix_bridged_hops($hop, $network);
14292
2
4
                    for my $rhop (@real_hop) {
14293
1
2
                        $interface->{hop}->{$rhop} = $rhop;
14294
1
4
                        $interface->{routes}->{$rhop}->{$network} = $network;
14295                    }
14296                }
14297
2
4
                delete $interface->{hop}->{$hop};
14298
2
7
                delete $interface->{routes}->{$hop};
14299            }
14300        }
14301    }
14302
14303
226
282
    for my $router (@managed_routers, @routing_only_routers) {
14304
14305        # Adjust routes through VPN tunnel to cleartext interface.
14306
365
365
297
454
        for my $interface (@{ $router->{interfaces} }) {
14307
862
1935
            next if not $interface->{ip} eq 'tunnel';
14308
21
17
            my $tunnel_routes = $interface->{routes};
14309
21
36
            $interface->{routes} = $interface->{hop} = {};
14310
21
26
            my $real_intf = $interface->{real_interface};
14311
21
31
            next if $real_intf->{routing};
14312
21
17
            my $real_net = $real_intf->{network};
14313
21
21
17
25
            for my $peer (@{ $interface->{peers} }) {
14314
21
20
                my $real_peer = $peer->{real_interface};
14315
21
21
                my $peer_net  = $real_peer->{network};
14316
14317                # Find hop to peer network and add tunnel networks to this hop.
14318
21
17
                my @hops;
14319
14320                # Peer network is directly connected.
14321
21
1013
                if ($real_net eq $peer_net) {
14322
0
0
                    if ($real_peer->{ip} !~ /^(?:short|negotiated)$/) {
14323
0
0
                        push @hops, $real_peer;
14324                    }
14325                    else {
14326
0
0
                        err_msg("$real_peer->{name} used to reach",
14327                                " software clients\n",
14328                                " must not be directly connected to",
14329                                " $real_intf->{name}\n",
14330                                " Connect it to some network behind next hop");
14331
0
0
                        next;
14332                    }
14333                }
14334
14335                # Peer network is located in directly connected zone.
14336                elsif ($real_net->{zone} eq $peer_net->{zone}) {
14337
21
19
                    my $route_in_zone = $real_intf->{route_in_zone};
14338
21
39
                    my $hops = $route_in_zone->{$peer_net} or
14339                        internal_err("Missing route for $peer_net->{name}",
14340                                     " at $real_intf->{name} ");
14341
21
28
                    push @hops, @$hops;
14342                }
14343
14344                # Find path to peer network to determine available hops.
14345                else {
14346
0
0
                    my $pseudo_rule = {
14347                        src    => $real_intf,
14348                        dst    => $peer_net,
14349                        action => '--',
14350                        prt    => { name => '--' },
14351                    };
14352
0
0
                    my @zone_hops;
14353                    my $walk = sub {
14354
0
0
                        my ($rule, $in_intf, $out_intf) = @_;
14355
0
0
                        $in_intf or internal_err("No in_intf");
14356
0
0
                        $in_intf eq $real_intf or return;
14357
0
0
                        $out_intf or internal_err("No out_intf");
14358
0
0
                        $out_intf->{network} or internal_err "No out net";
14359
0
0
                        push @zone_hops, $out_intf;
14360
0
0
                    };
14361
0
0
                    path_walk($pseudo_rule, $walk, 'Zone');
14362
0
0
                    my $route_in_zone = $real_intf->{route_in_zone};
14363
0
0
                    for my $hop (@zone_hops) {
14364
14365
0
0
                        my $hop_net = $hop->{network};
14366
0
0
                        if ($hop_net eq $real_net) {
14367
0
0
                            push @hops, $hop;
14368                        }
14369                        else {
14370
0
0
                            my $hops = $route_in_zone->{$hop_net} or
14371                                internal_err("Missing route for $hop_net->{name}",
14372                                             " at $real_intf->{name}");
14373
0
0
                            push @hops, @$hops;
14374                        }
14375                    }
14376                }
14377
14378
21
17
                my $hop_routes;
14379
21
2
76
6
                if (   @hops > 1
14380                    && equal(map({ $_->{redundancy_interfaces} || $_ }
14381                                 @hops))
14382                    || @hops == 1)
14383                {
14384
20
18
                    my $hop = shift @hops;
14385
20
51
                    $hop_routes = $real_intf->{routes}->{$hop} ||= {};
14386
20
32
                    $real_intf->{hop}->{$hop} = $hop;
14387#                    debug "Use $hop->{name} as hop for $real_peer->{name}";
14388                }
14389                else {
14390
14391                    # This can only happen for vpn software clients.
14392                    # For hardware clients  the route is known
14393                    # for the encrypted traffic which is allowed
14394                    # by gen_tunnel_rules (even for negotiated interface).
14395
1
2
                    my $count = @hops;
14396
2
6
                    my $names = join ('',
14397
1
1
                                      map({ "\n - $_->{name}" }
14398                                          @hops));
14399
1
11
                    err_msg(
14400                        "Can't determine next hop to reach $peer_net->{name}",
14401                        " while moving routes\n",
14402                        " of $interface->{name} to $real_intf->{name}.\n",
14403                        " Exactly one route is needed,",
14404                        " but $count candidates were found:",
14405                        $names);
14406                }
14407
14408                # Use found hop to reach tunneled networks in $tunnel_routes.
14409
21
39
                for my $tunnel_net_hash (values %$tunnel_routes) {
14410
17
26
                    for my $tunnel_net (values %$tunnel_net_hash) {
14411
23
48
                        $hop_routes->{$tunnel_net} = $tunnel_net;
14412                    }
14413                }
14414
14415                # Add route to reach peer interface.
14416
21
44
                if ($peer_net ne $real_net) {
14417
21
83
                    $hop_routes->{$peer_net} = $peer_net;
14418                }
14419            }
14420        }
14421
14422        # Remember, via which local interface a network is reached.
14423
365
320
        my %net2intf;
14424
14425
365
365
289
439
        for my $interface (@{ $router->{interfaces} }) {
14426
14427            # Remember, via which remote interface a network is reached.
14428
862
640
            my %net2hop;
14429
14430            # Remember, via which remote redundancy interfaces a network
14431            # is reached. We use this to check, if alle members of a group
14432            # of redundancy interfaces are used to reach the network.
14433            # Otherwise it would be wrong to route to the virtual interface.
14434            my %net2group;
14435
14436
862
1874
            next if $interface->{loop} and $interface->{routing};
14437
757
1096
            next if $interface->{ip} eq 'bridged';
14438
743
743
574
1854
            for my $hop (sort by_name values %{ $interface->{hop} }) {
14439
150
150
143
418
                for my $network (sort by_name
14440                                 values %{ $interface->{routes}->{$hop} })
14441                {
14442
226
382
                    if (my $interface2 = $net2intf{$network}) {
14443
11
28
                        if ($interface2 ne $interface) {
14444
14445                            # Network is reached via two different
14446                            # local interfaces.  Show warning if static
14447                            # routing is enabled for both interfaces.
14448
0
0
                            if (    not $interface->{routing}
14449                                and not $interface2->{routing})
14450                            {
14451
0
0
                                warn_msg (
14452                                  "Two static routes for $network->{name}\n",
14453                                  " via $interface->{name} and",
14454                                  " $interface2->{name}"
14455                                );
14456                            }
14457                        }
14458                    }
14459                    else {
14460
215
288
                        $net2intf{$network} = $interface;
14461                    }
14462
226
374
                    unless ($interface->{routing}) {
14463
226
199
                        my $group = $hop->{redundancy_interfaces};
14464
226
312
                        if ($group) {
14465
16
16
13
28
                            push @{ $net2group{$network} }, $hop;
14466                        }
14467
226
329
                        if (my $hop2 = $net2hop{$network}) {
14468
14469                            # Network is reached via two different hops.
14470                            # Check if both belong to same group
14471                            # of redundancy interfaces.
14472
11
12
                            my $group2 = $hop2->{redundancy_interfaces};
14473
11
50
                            if ($group && $group2 && $group eq $group2) {
14474
14475                                # Prevent multiple identical routes to
14476                                # different interfaces
14477                                # with identical virtual IP.
14478
8
29
                                delete $interface->{routes}->{$hop}->{$network};
14479                            }
14480                            else {
14481
3
26
                                warn_msg (
14482                                  "Two static routes for $network->{name}\n",
14483                                  " at $interface->{name}",
14484                                  " via $hop->{name} and $hop2->{name}"
14485                                );
14486                            }
14487                        }
14488                        else {
14489
215
510
                            $net2hop{$network} = $hop;
14490                        }
14491                    }
14492                }
14493            }
14494
743
1131
            for my $net_ref (keys %net2group) {
14495
8
8
                my $hops = $net2group{$net_ref};
14496
8
8
                my $hop1 = $hops->[0];
14497
8
8
7
17
                next if @$hops == @{ $hop1->{redundancy_interfaces} };
14498
2
4
                my $network = $interface->{routes}->{$hop1}->{$net_ref};
14499
14500                # A network is routed to a single physical interface.
14501                # It is probably a loopback interface of the same device.
14502                # Move hop from virtual to physical interface.
14503
2
10
                if (@$hops == 1 && (my $phys_hop = $hop1->{orig_main})) {
14504
1
2
                    delete $interface->{routes}->{$hop1}->{$net_ref};
14505
1
2
                    $interface->{routes}->{$phys_hop}->{$network} = $network;
14506
1
3
                    $interface->{hop}->{$phys_hop} = $phys_hop;
14507                }
14508                else {
14509
14510                    # This occurs if different redundancy groups use
14511                    # parts of of a group of routers.
14512                    # More than 3 virtual interfaces together with
14513                    # pathrestrictions have already been rejected.
14514
1
4
                    err_msg(
14515                        "$network->{name} is reached via $hop1->{name}\n",
14516                        " but not via all related redundancy interfaces"
14517                    );
14518                }
14519            }
14520
14521            # Convert to array, because hash isn't needed any longer.
14522            # Array is sorted to get deterministic output.
14523
743
2202
            $interface->{hop} =
14524
743
619
              [ sort by_name values %{ $interface->{hop} } ];
14525        }
14526    }
14527
226
237
    return;
14528}
14529
14530sub ios_route_code;
14531sub prefix_code;
14532sub full_prefix_code;
14533sub address;
14534
14535sub print_header {
14536
529
0
489
    my ($router, $what) = @_;
14537
529
559
    my $comment_char = $router->{model}->{comment_char};
14538
529
747
    my $where = $router->{vrf_members} ? " for $router->{name}" : '';
14539
529
980
    print "$comment_char [ $what$where ]\n";
14540
529
595
    return;
14541}
14542
14543sub print_routes {
14544
252
0
226
    my ($router)              = @_;
14545
252
254
    my $model                 = $router->{model};
14546
252
264
    my $type                  = $model->{routing};
14547
252
241
    my $vrf                   = $router->{vrf};
14548
252
231
    my $comment_char          = $model->{comment_char};
14549
252
267
    my $do_auto_default_route = $config{auto_default_route};
14550
252
517
    my $crypto_type           = $model->{crypto} || '';
14551
252
211
    my %intf2hop2nets;
14552    my @interfaces;
14553
0
0
    my %mask2ip2net;
14554
0
0
    my %net2hop_info;
14555
0
0
    my %net2no_opt;
14556
252
252
217
358
    for my $interface (@{ $router->{interfaces} }) {
14557
620
962
        next if $interface->{ip} eq 'bridged';
14558
610
866
        if ($interface->{routing}) {
14559
182
137
            $do_auto_default_route = 0;
14560
182
220
            next;
14561        }
14562
14563
428
371
        push @interfaces, $interface;
14564
14565        # ASA with site-to-site VPN needs individual routes for each peer.
14566
428
743
        if ($interface->{hub} && $crypto_type eq 'ASA') {
14567
5
5
            $do_auto_default_route = 0;
14568        }
14569
428
352
        my $no_nat_set = $interface->{no_nat_set};
14570
14571
428
428
333
704
        for my $hop (@{ $interface->{hop} }) {
14572
117
161
            my $hop_info = [ $interface, $hop ];
14573
14574            # A hash having all networks reachable via current hop
14575            # both as key and as value.
14576
117
200
            my $net_hash = $interface->{routes}->{$hop};
14577
117
183
            for my $network (values %$net_hash) {
14578
175
271
                my $nat_network = get_nat_network($network, $no_nat_set);
14579
175
175
154
251
                my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
14580
175
341
                if ($ip == 0 and $mask == 0) {
14581
10
10
                    $do_auto_default_route = 0;
14582                }
14583
14584                # Implicitly overwrite duplicate networks.
14585
175
1240
                $mask2ip2net{$mask}->{$ip} = $nat_network;
14586
175
521
                $net2hop_info{$nat_network} = $hop_info;
14587            }
14588        }
14589    }
14590
252
633
    return if not @interfaces;
14591
14592    # Find and remove duplicate networks.
14593    # Go from smaller to larger networks.
14594
179
374
    for my $mask (reverse sort keys %mask2ip2net) {
14595
131
335
      NETWORK:
14596
131
120
        for my $ip (sort numerically keys %{ $mask2ip2net{$mask} }) {
14597
170
178
            my $small = $mask2ip2net{$mask}->{$ip};
14598
170
230
            my $hop_info = $net2hop_info{$small};
14599
170
172
            my ($interface, $hop) = @$hop_info;
14600
14601            # ASA with site-to-site VPN needs individual routes for each peer.
14602
170
375
            if (!($interface->{hub} && $crypto_type eq 'ASA')) {
14603
14604
154
144
                my $m = $mask;
14605
154
126
                my $i = $ip;
14606
154
230
                while ($m) {
14607
14608                    # Clear upper bit, because left shift is undefined
14609                    # otherwise.
14610
3443
2488
                    $m = $m & 0x7fffffff;
14611
3443
2401
                    $m <<= 1;
14612
3443
2418
                    $i = $i & $m; # Perl bug #108480.
14613
3443
6642
                    my $ip2net = $mask2ip2net{$m} or next;
14614
44
103
                    my $big = $mask2ip2net{$m}->{$i} or next;
14615
14616                    # $small is subnet of $big.
14617                    # If both use the same hop, then $small is redundant.
14618
25
61
                    if ($net2hop_info{$big} eq $hop_info) {
14619#                        debug "Removed: $small->{name} -> $hop->{name}";
14620
14
40
                        next NETWORK;
14621                    }
14622
14623                    # Otherwise $small isn't redundant, even if a bigger network
14624                    # with same hop exists.
14625                    # It must not be removed by default route later.
14626
11
23
                    $net2no_opt{$small} = 1;
14627#                    debug "No opt: $small->{name} -> $hop->{name}";
14628
11
12
                    last;
14629                }
14630            }
14631
156
156
116
766
            push(@{ $intf2hop2nets{$interface}->{$hop} }, [ $ip, $mask, $small ]);
14632        }
14633    }
14634
14635
179
303
    if ($do_auto_default_route) {
14636
14637        # Find interface and hop with largest number of routing entries.
14638
162
143
        my $max_intf;
14639        my $max_hop;
14640
14641        # Substitute routes to one hop with a default route,
14642        # if there are at least two entries.
14643
162
144
        my $max = 1;
14644
162
182
        for my $interface (@interfaces) {
14645
382
382
263
577
            for my $hop (@{ $interface->{hop} }) {
14646
123
101
266
321
                my $count = grep({ !$net2no_opt{$_->[2]} }
14647
101
78
                                 @{ $intf2hop2nets{$interface}->{$hop} || [] });
14648
101
260
                if ($count > $max) {
14649
12
14
                    $max_intf = $interface;
14650
12
12
                    $max_hop  = $hop;
14651
12
30
                    $max      = $count;
14652                }
14653            }
14654        }
14655
162
364
        if ($max_intf && $max_hop) {
14656
14657            # Use default route for this direction.
14658            # But still generate routes for small networks
14659            # with supernet behind other hop.
14660
37
69
            $intf2hop2nets{$max_intf}->{$max_hop} =
14661                [ [ 0, 0 ],
14662
12
26
                  grep({ $net2no_opt{$_->[2]} }
14663
12
22
                       @{ $intf2hop2nets{$max_intf}->{$max_hop} })
14664                ];
14665        }
14666    }
14667
179
332
    print_header($router, 'Routing');
14668
14669
179
151
    my $ios_vrf;
14670
179
356
    $ios_vrf = $vrf ? "vrf $vrf " : '' if $type eq 'IOS';
14671
179
165
    my $nxos_prefix = '';
14672
14673
179
208
    for my $interface (@interfaces) {
14674
428
428
325
644
        for my $hop (@{ $interface->{hop} }) {
14675
14676            # For unnumbered and negotiated interfaces use interface name
14677            # as next hop.
14678
117
408
            my $hop_addr =
14679                $interface->{ip} =~ /^(?:unnumbered|negotiated|tunnel)$/
14680              ? $interface->{hardware}->{name}
14681              : print_ip $hop->{ip};
14682
14683
117
117
124
291
            for my $netinfo (@{ $intf2hop2nets{$interface}->{$hop} }) {
14684
132
231
                if ($config{comment_routes}) {
14685
0
0
                    if (my $net = $netinfo->[2]) {
14686
0
0
                        print("$comment_char route",
14687                              " $net->{name} -> $hop->{name}\n");
14688                    }
14689                }
14690
132
307
                if ($type eq 'IOS') {
14691
39
64
                    my $adr = ios_route_code($netinfo);
14692
39
174
                    print "ip route $ios_vrf$adr $hop_addr\n";
14693                }
14694                elsif ($type eq 'NX-OS') {
14695
18
47
                    if ($vrf && ! $nxos_prefix) {
14696
14697                        # Print "vrf context" only once
14698                        # and indent "ip route" commands.
14699
4
10
                        print "vrf context $vrf\n";
14700
4
5
                        $nxos_prefix = ' ';
14701                    }
14702
18
28
                    my $adr = full_prefix_code($netinfo);
14703
18
66
                    print "${nxos_prefix}ip route $adr $hop_addr\n";
14704                }
14705                elsif ($type eq 'PIX') {
14706
60
89
                    my $adr = ios_route_code($netinfo);
14707
60
350
                    print
14708                      "route $interface->{hardware}->{name} $adr $hop_addr\n";
14709                }
14710                elsif ($type eq 'iproute') {
14711
15
25
                    my $adr = prefix_code($netinfo);
14712
15
66
                    print "ip route add $adr via $hop_addr\n";
14713                }
14714                elsif ($type eq 'none') {
14715
14716                    # Do nothing.
14717                }
14718                else {
14719
0
0
                    internal_err("unexpected routing type '$type'");
14720                }
14721            }
14722        }
14723    }
14724
179
760
    return;
14725}
14726
14727##############################################################################
14728# NAT commands
14729##############################################################################
14730
14731sub print_nat1 {
14732
92
0
112
    my ($router, $print_dynamic, $print_static_host, $print_static) = @_;
14733
92
101
    my $model        = $router->{model};
14734
92
94
    my $comment_char = $model->{comment_char};
14735
14736
92
142
    print_header($router, 'NAT');
14737
14738
131
254
    my @hardware =
14739
92
92
83
220
      sort { $a->{level} <=> $b->{level} } @{ $router->{hardware} };
14740
14741
92
133
    for my $in_hw (@hardware) {
14742
208
418
        my $src_nat = $in_hw->{src_nat} or next;
14743
17
16
        my $in_nat = $in_hw->{no_nat_set};
14744
17
20
        for my $out_hw (@hardware) {
14745
14746            # Value is { net => net, .. }
14747
44
105
            my $net_hash = $src_nat->{$out_hw} or next;
14748
21
19
            my $out_nat = $out_hw->{no_nat_set};
14749
14750            # Sorting is only needed for getting output deterministic.
14751            # For equal addresses look at the NAT address.
14752
0
0
            my @networks =
14753              sort {
14754
21
35
                     $a->{ip} <=> $b->{ip}
14755                  || $a->{mask} <=> $b->{mask}
14756                  || get_nat_network($a, $out_nat)
14757                  ->{ip} <=> get_nat_network($b, $out_nat)->{ip}
14758              } values %$net_hash;
14759
14760
21
22
            for my $network (@networks) {
14761
21
30
                my ($in_ip, $in_mask, $in_dynamic) =
14762
21
21
                  @{ get_nat_network($network, $in_nat) }{qw(ip mask dynamic)};
14763
21
26
                my ($out_ip, $out_mask, $out_dynamic) =
14764
21
24
                  @{ get_nat_network($network, $out_nat) }{qw(ip mask dynamic)};
14765
14766                # Ignore dynamic translation, which doesn't occur at
14767                # current router
14768
21
73
                if (    $out_dynamic
14769                    and $in_dynamic
14770                    and $out_dynamic eq $in_dynamic)
14771                {
14772
0
0
                    $out_dynamic = $in_dynamic = undef;
14773                }
14774
14775                # We are talking about source addresses.
14776
21
27
                if ($out_dynamic) {
14777
14778                    # Check for static NAT entries of hosts and interfaces.
14779
15
15
15
14
21
19
                    for my $host (@{ $network->{subnets} },
14780                        @{ $network->{interfaces} })
14781                    {
14782
18
51
                        if (my $out_host_ip = $host->{nat}->{$out_dynamic}) {
14783
3
5
                            my $pair = address($host, $in_nat);
14784
3
4
                            my ($in_host_ip, $in_host_mask) = @$pair;
14785
3
6
                            $print_static_host->(
14786                                $in_hw, $in_host_ip, $in_host_mask, $out_hw,
14787                                $out_host_ip
14788                            );
14789                        }
14790                    }
14791
15
24
                    $print_dynamic->(
14792                        $in_hw,  $in_ip,  $in_mask,
14793                        $out_hw, $out_ip, $out_mask
14794                    );
14795                }
14796                else {
14797
6
10
                    $print_static->($in_hw, $in_ip, $in_mask, $out_hw, $out_ip);
14798                }
14799            }
14800        }
14801    }
14802
92
150
    return;
14803}
14804
14805sub print_pix_static {
14806
86
0
89
    my ($router) = @_;
14807
14808    # Index for linking "global" and "nat" commands.
14809
86
81
    my $dyn_index = 1;
14810
14811    # Hash of indexes for reusing of NAT pools.
14812
86
68
    my %global2index;
14813
14814    # Hash of indexes for creating only a single "nat" command if mapped at
14815    # different interfaces.
14816    my %nat2index;
14817
14818    my $print_dynamic = sub {
14819
11
15
        my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_;
14820
11
14
        my $in_name  = $in_hw->{name};
14821
11
11
        my $out_name = $out_hw->{name};
14822
14823        # Use a single "global" command if multiple networks are
14824        # mapped to a single pool.
14825
11
28
        my $global_index = $global2index{$out_name}->{$out_ip}->{$out_mask};
14826
14827        # Use a single "nat" command if one network is mapped to
14828        # different pools at different interfaces.
14829
11
22
        my $nat_index = $nat2index{$in_name}->{$in_ip}->{$in_mask};
14830
11
28
        $global_index and $nat_index and internal_err();
14831
14832
11
43
        my $index = $global_index || $nat_index || $dyn_index++;
14833
11
17
        if (not $global_index) {
14834
8
23
            $global2index{$out_name}->{$out_ip}->{$out_mask} = $index;
14835
8
8
            my $pool;
14836
14837            # global (outside) 1 interface
14838
8
14
            my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip};
14839
8
21
            if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) {
14840
0
0
                $pool = 'interface';
14841            }
14842
14843            # global (outside) 1 10.7.6.0-10.7.6.255 netmask 255.255.255.0
14844            # nat (inside) 1 14.4.36.0 255.255.252.0
14845            else {
14846
8
12
                my $max  = $out_ip | complement_32bit $out_mask;
14847
8
13
                my $mask = print_ip $out_mask;
14848
8
19
                my $range =
14849                  ($out_ip == $max)
14850                  ? print_ip($out_ip)
14851                  : print_ip($out_ip) . '-' . print_ip($max);
14852
8
17
                $pool = "$range netmask $mask";
14853            }
14854
8
36
            print "global ($out_name) $index $pool\n";
14855        }
14856
14857
11
27
        if (not $nat_index) {
14858
9
25
            $nat2index{$in_name}->{$in_ip}->{$in_mask} = $index;
14859
9
12
            my $in   = print_ip $in_ip;
14860
9
12
            my $mask = print_ip $in_mask;
14861
9
41
            print "nat ($in_name) $index $in $mask";
14862
9
23
            print " outside" if $in_hw->{level} < $out_hw->{level};
14863
9
32
            print "\n";
14864        }
14865
86
414
    };
14866    my $print_static_host = sub {
14867
2
6
        my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_;
14868
2
2
        my $in_name  = $in_hw->{name};
14869
2
4
        my $out_name = $out_hw->{name};
14870
2
2
        my $in       = print_ip $in_host_ip;
14871
2
3
        my $mask     = print_ip $in_host_mask;
14872
2
3
        my $out      = print_ip $out_host_ip;
14873
2
20
        print "static ($in_name,$out_name) $out $in netmask $mask\n";
14874
86
226
    };
14875    my $print_static = sub {
14876
6
8
        my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_;
14877
6
37
        if (   $in_hw->{level} > $out_hw->{level}
14878            || $in_hw->{need_identity_nat}
14879            || $in_ip != $out_ip)
14880        {
14881
6
7
            my $in_name  = $in_hw->{name};
14882
6
5
            my $out_name = $out_hw->{name};
14883
6
9
            my $in       = print_ip $in_ip;
14884
6
8
            my $out      = print_ip $out_ip;
14885
6
8
            my $mask     = print_ip $in_mask;
14886
14887            # static (inside,outside) \
14888            #   10.111.0.0 111.0.0.0 netmask 255.255.252.0
14889
6
57
            print "static ($in_name,$out_name) $out $in netmask $mask\n";
14890        }
14891
86
236
    };
14892
86
142
    print_nat1($router, $print_dynamic, $print_static_host, $print_static);
14893
86
86
73
116
    for my $in_hw (@{ $router->{hardware} }) {
14894
194
348
        next if not $in_hw->{need_nat_0};
14895
0
0
        print "nat ($in_hw->{name}) 0 0.0.0.0 0.0.0.0\n";
14896    }
14897
86
2268
    return;
14898}
14899
14900sub print_asa_nat {
14901
6
0
7
    my ($router) = @_;
14902
14903    # Hash for re-using object definitions.
14904
6
6
    my %objects;
14905
14906    my $subnet_obj = sub {
14907
6
6
        my ($ip, $mask) = @_;
14908
6
12
        my $p_ip   = print_ip($ip);
14909
6
8
        my $p_mask = print_ip($mask);
14910
6
12
        my $name   = "${p_ip}_${p_mask}";
14911
6
10
        if (not $objects{$name}) {
14912
4
9
            print "object network $name\n";
14913
4
6
            print " subnet $p_ip $p_mask\n";
14914
4
7
            $objects{$name} = $name;
14915        }
14916
6
9
        return $name;
14917
6
25
    };
14918    my $range_obj = sub {
14919
4
6
        my ($ip, $mask) = @_;
14920
4
4
        my $max  = $ip | complement_32bit $mask;
14921
4
4
        my $p_ip = print_ip($ip);
14922
4
4
        my $name = $p_ip;
14923
4
3
        my $sub_cmd;
14924
4
6
        if ($ip == $max) {
14925
2
3
            $sub_cmd = "host $p_ip";
14926        }
14927        else {
14928
2
3
            my $p_max = print_ip($max);
14929
2
4
            $name .= "-$p_max";
14930
2
3
            $sub_cmd = "range $p_ip $p_max";
14931        }
14932
4
9
        if (not $objects{$name}) {
14933
3
6
            print "object network $name\n";
14934
3
5
            print " $sub_cmd\n";
14935
3
4
            $objects{$name} = $name;
14936        }
14937
4
5
        return $name;
14938
6
23
    };
14939
14940    my $print_dynamic = sub {
14941
4
6
        my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_;
14942
4
4
        my $in_name  = $in_hw->{name};
14943
4
5
        my $out_name = $out_hw->{name};
14944
4
5
        my $in_obj   = $subnet_obj->($in_ip, $in_mask);
14945
4
3
        my $out_obj;
14946
14947        # NAT to interface
14948
4
4
        my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip};
14949
4
10
        if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) {
14950
0
0
            $out_obj = 'interface';
14951        }
14952        else {
14953
4
4
            $out_obj = $range_obj->($out_ip, $out_mask);
14954        }
14955
4
28
        print("nat ($in_name,$out_name) source dynamic $in_obj $out_obj\n");
14956
6
20
    };
14957    my $print_static_host = sub {
14958
1
1
        my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_;
14959
1
2
        my $in_name      = $in_hw->{name};
14960
1
1
        my $out_name     = $out_hw->{name};
14961
1
2
        my $in_host_obj  = $subnet_obj->($in_host_ip, $in_host_mask);
14962
1
2
        my $out_host_obj = $subnet_obj->($out_host_ip, $in_host_mask);
14963
14964        # Print with line number 1 because static host NAT must be
14965        # inserted in front of dynamic network NAT.
14966
1
6
        print("nat ($in_name,$out_name) 1 source static",
14967            " $in_host_obj $out_host_obj\n");
14968
6
25
    };
14969    my $print_static = sub {
14970
0
0
        my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_;
14971
0
0
        my $in_name  = $in_hw->{name};
14972
0
0
        my $out_name = $out_hw->{name};
14973
0
0
        my $in_obj   = $subnet_obj->($in_ip, $in_mask);
14974
0
0
        my $out_obj  = $subnet_obj->($out_ip, $in_mask);
14975
0
0
        print("nat ($in_name,$out_name) source static $in_obj $out_obj\n");
14976
6
21
    };
14977
6
11
    print_nat1($router, $print_dynamic, $print_static_host, $print_static);
14978
6
103
    return;
14979}
14980
14981sub optimize_nat_networks {
14982
92
0
95
    my ($router) = @_;
14983
92
92
88
154
    my @hardware = @{ $router->{hardware} };
14984
92
120
    for my $in_hw (@hardware) {
14985
208
397
        my $src_nat = $in_hw->{src_nat} or next;
14986
17
17
        my $in_nat = $in_hw->{no_nat_set};
14987
17
18
        for my $out_hw (@hardware) {
14988
14989            # Value is { net => net, .. }
14990
44
108
            my $net_hash = $src_nat->{$out_hw} or next;
14991
21
21
            my $out_nat = $out_hw->{no_nat_set};
14992
14993            # Prevent duplicate entries from different networks
14994            # translated to one identical address.
14995
21
23
            my @has_indentical;
14996
21
37
            for my $network (values %$net_hash) {
14997
21
51
                my $identical = $network->{is_identical} or next;
14998
3
5
                my $in        = $identical->{$in_nat};
14999
3
3
                my $out       = $identical->{$out_nat};
15000
3
10
                if ($in && $out && $in eq $out) {
15001
0
0
                    push @has_indentical, $network;
15002                }
15003            }
15004
21
26
            for my $network (@has_indentical) {
15005
0
0
                delete $net_hash->{$network};
15006
0
0
                my $one_net = $network->{is_identical}->{$out_nat};
15007
0
0
                $net_hash->{$one_net} = $one_net;
15008            }
15009
15010            # Remove redundant networks.
15011            # A network is redundant if some enclosing network is found
15012            # in both NAT domains of incoming and outgoing interface.
15013
21
32
            for my $network (values %$net_hash) {
15014
21
29
                my $net = $network->{is_in}->{$out_nat};
15015
21
59
                while ($net) {
15016
3
3
                    my $net2;
15017
3
10
                    if (    $net_hash->{$net}
15018                        and $net2 = $network->{is_in}->{$in_nat}
15019                        and $net_hash->{$net2})
15020                    {
15021
0
0
                        delete $net_hash->{$network};
15022
0
0
                        last;
15023                    }
15024                    else {
15025
3
10
                        $net = $net->{is_in}->{$out_nat};
15026                    }
15027                }
15028            }
15029        }
15030    }
15031
92
123
    return;
15032}
15033
15034sub print_nat {
15035
248
0
211
    my ($router) = @_;
15036
248
252
    my $model = $router->{model};
15037
15038    # NAT commands not implemented for other models.
15039
248
560
    return if not $model->{has_interface_level};
15040
15041
92
156
    optimize_nat_networks($router);
15042
92
145
    if ($model->{v8_4}) {
15043
15044
6
14
        print_asa_nat($router);
15045    }
15046    else {
15047
86
137
        print_pix_static($router);
15048    }
15049
92
177
    return;
15050}
15051
15052##############################################################################
15053# Distributing rules to managed devices
15054##############################################################################
15055
15056sub distribute_rule {
15057
702
0
630
    my ($rule, $in_intf, $out_intf) = @_;
15058
15059    # Traffic from src reaches this router via in_intf
15060    # and leaves it via out_intf.
15061    # in_intf is undefined if src is an interface of current router.
15062    # out_intf is undefined if dst is an interface of current router.
15063    # Outgoing packets from a router itself are never filtered.
15064
702
977
    return unless $in_intf;
15065
647
601
    my $router = $in_intf->{router};
15066
647
1024
    return if not $router->{managed};
15067
625
541
    my $model = $router->{model};
15068
15069    # Rules of type stateless must only be processed at
15070    # - stateless routers or
15071    # - routers which are stateless for packets destined for
15072    #   their own interfaces or
15073    # - stateless tunnel interfaces of ASA-VPN.
15074
625
909
    if ($rule->{stateless}) {
15075
78
177
        if (
15076            not(   $model->{stateless}
15077                or not $out_intf and $model->{stateless_self})
15078          )
15079        {
15080
17
25
            return;
15081        }
15082    }
15083
15084    # Rules of type stateless_icmp must only be processed at routers
15085    # which don't handle stateless_icmp automatically;
15086
608
1037
    return if $rule->{stateless_icmp} and not $model->{stateless_icmp};
15087
15088
608
498
    my $dst       = $rule->{dst};
15089
608
514
    my $intf_hash = $router->{crosslink_intf_hash};
15090
15091    # Rule to managed interface must be processed
15092    # - at the corresponding router or
15093    # - at the edge of a cluster of crosslinked routers
15094    # even if the rule is marked as deleted,
15095    # because code for interface is placed separately into {intf_rules}.
15096
608
855
    if ($rule->{deleted}) {
15097
15098        # We are at an intermediate router.
15099
1
3
        return if $out_intf and (!$intf_hash || !$intf_hash->{$dst});
15100
15101        # No code needed if it is deleted by another rule to the same interface.
15102
1
2
        return if $rule->{deleted}->{managed_intf};
15103    }
15104
15105    # Don't generate code for src any:[interface:r.loopback] at router:r.
15106
608
838
    return if $in_intf->{loopback};
15107
15108    # Adapt rule to dynamic NAT.
15109
608
930
    if (my $dynamic_nat = $rule->{dynamic_nat}) {
15110
0
0
        my $no_nat_set = $in_intf->{no_nat_set};
15111
0
0
        my $orig_rule = $rule;
15112
0
0
        for my $where (split(/,/, $dynamic_nat)) {
15113
0
0
            my $obj         = $rule->{$where};
15114
0
0
            my $network     = $obj->{network};
15115
0
0
            my $nat_network = get_nat_network($network, $no_nat_set);
15116
0
0
            next if $nat_network eq $network;
15117
0
0
            my $nat_tag = $nat_network->{dynamic} or next;
15118
15119            # Ignore object with static translation.
15120
0
0
            next if $obj->{nat}->{$nat_tag};
15121
15122            # Otherwise, filtering occurs at other router, therefore
15123            # the whole network can pass here.
15124            # But attention, this assumption only holds, if the other
15125            # router filters fully.  Hence disable optimization of
15126            # secondary rules.
15127
0
0
            delete $orig_rule->{some_non_secondary};
15128
0
0
            delete $orig_rule->{some_primary};
15129
15130            # Permit whole network, because no static address is known.
15131            # Make a copy of current rule, because the original rule
15132            # must not be changed.
15133
0
0
            $rule = { %$rule, $where => $network };
15134        }
15135    }
15136
15137
608
447
    my $key;
15138
15139    # Packets for the router itself or for some interface of a
15140    # crosslinked cluster of routers (only IOS, NX-OS with "need_protect").
15141
608
1814
    if (!$out_intf || $intf_hash && $intf_hash->{$dst}) {
15142
15143        # Packets for the router itself.  For PIX we can only reach that
15144        # interface, where traffic enters the PIX.
15145
121
211
        if ($model->{filter} eq 'PIX') {
15146
32
96
            if ($dst eq $in_intf) {
15147            }
15148            elsif ($dst eq $network_00 or $dst eq $in_intf->{network}) {
15149
15150                # Ignore rule, because generated code would permit traffic
15151                # to cleartext interface as well.
15152
8
16
                return if $in_intf->{ip} eq 'tunnel';
15153
15154                # Change destination in $rule to interface.
15155                # Make a copy of current rule, because the
15156                # original rule must not be changed.
15157
8
18
                $rule = {%$rule};
15158
8
14
                $rule->{dst} = $in_intf;
15159            }
15160
15161            # Permit management access through tunnel.
15162            # On ASA device use command "management-access".
15163            # Permit management access through bridged interface.
15164            elsif ($in_intf->{ip} =~ /^(?:tunnel|bridged)/) {
15165            }
15166
15167            # Silently ignore everything else.
15168            else {
15169
0
0
                return;
15170            }
15171        }
15172
121
115
        $key = 'intf_rules';
15173    }
15174    elsif ($out_intf->{hardware}->{need_out_acl}) {
15175
9
9
        $key = 'out_rules';
15176
9
22
        if (not $in_intf->{hardware}->{no_in_acl}) {
15177
2
2
2
9
            push @{ $in_intf->{hardware}->{rules} }, $rule;
15178        }
15179    }
15180    else {
15181
478
440
        $key = 'rules';
15182    }
15183
15184
608
2049
    if ($in_intf->{ip} eq 'tunnel') {
15185
15186        # Rules for single software clients are stored individually.
15187        # Consistency checks have already been done at expand_crypto.
15188        # Rules are needed at tunnel for generating split tunnel ACL
15189        # regardless of $router->{no_crypto_filter} value.
15190
39
58
        if (my $id2rules = $in_intf->{id_rules}) {
15191
22
20
            my $src = $rule->{src};
15192
22
25
            if (is_subnet $src) {
15193
22
33
                my $id = $src->{id}
15194                  or internal_err("$src->{name} must have ID");
15195
22
42
                my $id_intf = $id2rules->{$id}
15196                  or internal_err("No entry for $id at id_rules");
15197
22
22
15
33
                push @{ $id_intf->{$key} }, $rule;
15198            }
15199            elsif (is_network $src) {
15200
0
0
                $src->{has_id_hosts}
15201                  or internal_err("$src->{name} must have ID-hosts\n ",
15202                                  print_rule $rule);
15203
0
0
0
0
0
0
                for my $id (map { $_->{id} } @{ $src->{hosts} }) {
15204
0
0
0
0
                    push @{ $id2rules->{$id}->{$key} }, $rule;
15205                }
15206            }
15207            else {
15208
0
0
                internal_err(
15209                    "Expected host or network as src but got $src->{name}\n ",
15210                    print_rule $rule);
15211            }
15212        }
15213
15214
39
63
        if ($router->{no_crypto_filter}) {
15215
36
36
25
57
            push @{ $in_intf->{real_interface}->{hardware}->{$key} }, $rule;
15216        }
15217
15218        # Rules are needed at tunnel for generating detailed_crypto_acl.
15219
39
61
        if (not $in_intf->{id_rules}) {
15220
17
17
13
24
            push @{ $in_intf->{$key} }, $rule;
15221        }
15222    }
15223    elsif ($key eq 'out_rules') {
15224
9
9
8
16
        push @{ $out_intf->{hardware}->{$key} }, $rule;
15225    }
15226
15227    # Remember outgoing interface.
15228    elsif ($key eq 'rules' and $model->{has_io_acl}) {
15229
63
63
49
141
        push @{ $in_intf->{hardware}->{io_rules}
15230              ->{ $out_intf->{hardware}->{name} } }, $rule;
15231    }
15232    else {
15233
497
497
377
789
        push @{ $in_intf->{hardware}->{$key} }, $rule;
15234    }
15235
608
883
    return;
15236}
15237
15238my $permit_any_rule;
15239
15240sub add_router_acls  {
15241
155
0
203
    for my $router (@managed_routers) {
15242
257
269
        my $has_io_acl = $router->{model}->{has_io_acl};
15243
257
257
208
324
        for my $hardware (@{ $router->{hardware} }) {
15244
15245            # Some managed devices are connected by a crosslink network.
15246            # Permit any traffic at the internal crosslink interface.
15247
559
820
            if ($hardware->{crosslink}) {
15248
15249                # We can savely change rules at hardware interface
15250                # because it has been checked that no other logical
15251                # networks are attached to the same hardware.
15252                #
15253                # Substitute rules for each outgoing interface.
15254
10
15
                if ($has_io_acl) {
15255
0
0
0
0
                    for my $rules (values %{ $hardware->{io_rules} }) {
15256
0
0
                        $rules = [$permit_any_rule];
15257                    }
15258                }
15259                else {
15260
10
16
                    $hardware->{rules} = [$permit_any_rule];
15261
10
16
                    if ($hardware->{need_out_acl}) {
15262
0
0
                        $hardware->{out_rules} = [$permit_any_rule];
15263                    }
15264                }
15265
10
18
                $hardware->{intf_rules} = [$permit_any_rule];
15266
10
13
                next;
15267            }
15268
15269
549
549
389
636
            for my $interface (@{ $hardware->{interfaces} }) {
15270
15271                # Current router is used as default router even for
15272                # some internal networks.
15273
600
843
                if ($interface->{reroute_permit}) {
15274
0
0
0
0
                    for my $net (@{ $interface->{reroute_permit} }) {
15275
15276                        # Prepend to all other rules.
15277
0
0
                        unshift(
15278                            @{
15279
0
0
                                $has_io_acl
15280
15281                                  # Incoming and outgoing interface are equal.
15282                                ? $hardware->{io_rules}->{ $hardware->{name} }
15283                                : $hardware->{rules}
15284                              },
15285                            {
15286                                src => $network_00,
15287                                dst => $net,
15288                                prt => $prt_ip
15289                            }
15290                        );
15291                    }
15292                }
15293
15294                # Is dynamic routing used?
15295
600
878
                if (my $routing = $interface->{routing}) {
15296
182
457
                    if($routing->{name} !~ /^(?:manual|dynamic)$/) {
15297
1
1
                        my $prt = $routing->{prt};
15298
1
3
                        if (my $dst_range = $prt->{dst_range}) {
15299
0
0
                            $prt = $dst_range;
15300                        }
15301
1
1
                        my $network = $interface->{network};
15302
15303                        # Permit multicast packets from current network.
15304
1
1
1
2
                        for my $mcast (@{ $routing->{mcast} }) {
15305
2
2
2
4
                            push @{ $hardware->{intf_rules} },
15306                              {
15307                                src => $network,
15308                                dst => $mcast,
15309                                prt => $prt
15310                              };
15311
2
4
                            $ref2obj{$mcast} = $mcast;
15312                        }
15313                        # Additionally permit unicast packets.
15314                        # We use the network address as destination
15315                        # instead of the interface address,
15316                        # because we get fewer rules if the interface has
15317                        # multiple addresses.
15318
1
1
2
3
                        push @{ $hardware->{intf_rules} },
15319                          {
15320                            src => $network,
15321                            dst => $network,
15322                            prt => $prt
15323                          };
15324                    }
15325                }
15326
15327                # Handle multicast packets of redundancy protocols.
15328
600
836
                if (my $type = $interface->{redundancy_type}) {
15329
14
14
                    my $network = $interface->{network};
15330
14
18
                    my $mcast   = $xxrp_info{$type}->{mcast};
15331
14
16
                    my $prt     = $xxrp_info{$type}->{prt};
15332
14
19
                    if (my $dst_range = $prt->{dst_range}) {
15333
2
2
                        $prt = $dst_range;
15334                    }
15335
14
14
11
30
                    push @{ $hardware->{intf_rules} },
15336                      {
15337                        src => $network,
15338                        dst => $mcast,
15339                        prt => $prt
15340                      };
15341
14
26
                    $ref2obj{$mcast} = $mcast;
15342                }
15343
15344                # Handle DHCP requests.
15345
600
1503
                if ($interface->{dhcp_server}) {
15346
1
1
1
5
                    push @{ $hardware->{intf_rules} },
15347                      {
15348                        src => $network_00,
15349                        dst => $network_00,
15350                        prt => $prt_bootps->{dst_range}
15351                      };
15352                }
15353            }
15354        }
15355    }
15356
155
158
    return;
15357}
15358
15359# At least for $prt_esp and $prt_ah the ACL lines need to have a fixed order.
15360# Otherwise,
15361# - if the device is accessed over an IPSec tunnel
15362# - and we change the ACL incrementally,
15363# the connection may be lost.
15364sub cmp_address {
15365
36
0
28
    my ($obj) = @_;
15366
36
29
    my $type = ref $obj;
15367
36
106
    if ($type eq 'Network' or $type eq 'Subnet') {
15368
0
0
        return "$obj->{ip},$obj->{mask}";
15369    }
15370    elsif ($type eq 'Interface') {
15371
36
93
        return("$obj->{ip}," . 0xffffffff); ## no critic (MismatchedOperators)
15372    }
15373    else {
15374
0
0
        internal_err();
15375    }
15376}
15377
15378sub distribute_rules {
15379
24
0
24
    my ($rules, $in_intf, $out_intf) = @_;
15380
24
25
    for my $rule (@$rules) {
15381
36
45
        distribute_rule($rule, $in_intf, $out_intf);
15382    }
15383
24
40
    return;
15384}
15385
15386sub create_general_permit_rules {
15387
9
0
10
    my ($protocols, $context) = @_;
15388
9
9
    my @rules;
15389
9
13
    for my $prt (@$protocols) {
15390
15391        # Prevent modification of original array.
15392
13
12
        my $prt = $prt;
15393
13
34
        if (ref $prt eq 'ARRAY') {
15394
2
3
            (my $src_range, $prt, my $orig_prt) = @$prt;
15395        }
15396        elsif (my $main_prt = $prt->{main}) {
15397
2
2
            $prt = $main_prt;
15398        }
15399
13
26
        my $rule = {
15400            src => $network_00,
15401            dst => $network_00,
15402            prt => $prt,
15403        };
15404
13
20
        push @rules, $rule;
15405    }
15406
9
17
    return \@rules;
15407}
15408
15409sub distribute_general_permit {
15410
155
0
184
    for my $router (@managed_routers) {
15411
257
549
        my $general_permit = $router->{general_permit} or next;
15412
9
26
        my $rules =
15413            create_general_permit_rules(
15414                $general_permit, "general_permit of $router->{name}");
15415
9
12
        my $need_protect = $router->{need_protect};
15416
9
9
10
10
        for my $in_intf (@{ $router->{interfaces} }) {
15417
16
29
            next if $in_intf->{main_interface};
15418
15419            # At VPN hub, don't permit any -> any, but only traffic
15420            # from each encrypted network.
15421
16
25
            if ($in_intf->{is_hub}) {
15422
3
3
                my $id_rules = $in_intf->{id_rules};
15423
3
5
6
7
                for my $src (
15424                    $id_rules
15425
1
2
                    ? map({ $_->{src} } values %$id_rules)
15426                    : @{ $in_intf->{peer_networks} }
15427                    )
15428                {
15429
7
8
                    for my $rule (@$rules) {
15430
7
13
                        my $rule = {%$rule};
15431
7
8
                        $rule->{src} = $src;
15432
7
7
7
7
                        for my $out_intf (@{ $router->{interfaces} }) {
15433
14
45
                            next if $out_intf eq $in_intf;
15434
7
12
                            next if $out_intf->{ip} eq 'tunnel';
15435
15436                            # Traffic traverses the device.
15437                            # Traffic for the device itself isn't needed
15438                            # at VPN hub.
15439
7
7
                            distribute_rule($rule, $in_intf, $out_intf);
15440                        }
15441                    }
15442                }
15443            }
15444            else {
15445
13
13
12
18
                for my $out_intf (@{ $router->{interfaces} }) {
15446
26
55
                    next if $out_intf eq $in_intf;
15447
15448                    # For IOS and NX-OS print this rule only
15449                    # once at interface filter rules below
15450                    # (for incoming ACL).
15451
13
20
                    if ($need_protect) {
15452
2
3
                        my $out_hw = $out_intf->{hardware};
15453
15454                                # For interface with outgoing ACLs
15455                                # we need to add the rule.
15456                                # distribute_rule would add rule to incoming,
15457                                # hence we add rule directly to outgoing rules.
15458
2
3
                        if ($out_hw->{need_out_acl}) {
15459
0
0
0
0
                            push @{ $out_hw->{out_rules} }, @$rules;
15460                        }
15461
2
3
                        next;
15462                    }
15463
11
17
                    next if $out_intf->{main_interface};
15464
15465                    # Traffic traverses the device.
15466
11
16
                    distribute_rules($rules, $in_intf, $out_intf);
15467                }
15468
15469                # Traffic for the device itself.
15470
13
24
                next if $in_intf->{ip} eq 'bridged';
15471
13
18
                distribute_rules($rules, $in_intf, undef);
15472            }
15473        }
15474    }
15475
155
150
    return;
15476}
15477
15478sub sort_rules_by_prio {
15479
15480    # Sort rules by reverse priority of protocol.
15481    # This should be done late to get all auxiliary rules processed.
15482
155
0
209
    for my $type ('deny', 'supernet', 'permit') {
15483
534
3709
        $expanded_rules{$type} = [
15484            sort {
15485
465
977
                     ($b->{prt}->{prio} || 0) <=> ($a->{prt}->{prio} || 0)
15486                  || ($a->{prt}->{prio} || 0)
15487                  && ( cmp_address($a->{src}) cmp cmp_address($b->{src})
15488                    || cmp_address($a->{dst}) cmp cmp_address($b->{dst}))
15489
465
343
              } @{ $expanded_rules{$type} }
15490        ];
15491    }
15492
155
156
    return;
15493}
15494
15495sub rules_distribution {
15496
208
0
248
    return if fast_mode();
15497
155
234
    progress('Distributing rules');
15498
15499
155
216
    sort_rules_by_prio();
15500
15501    # Deny rules
15502
155
155
141
234
    for my $rule (@{ $expanded_rules{deny} }) {
15503
0
0
        next if $rule->{deleted};
15504
0
0
        path_walk($rule, \&distribute_rule);
15505    }
15506
15507    # Handle global permit after deny rules.
15508
155
254
    distribute_general_permit();
15509
15510    # Permit rules
15511
155
155
155
132
184
209
    for my $rule (@{ $expanded_rules{supernet} }, @{ $expanded_rules{permit} })
15512    {
15513        next
15514
474
767
          if $rule->{deleted}
15515              and
15516              (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
15517
458
677
        path_walk($rule, \&distribute_rule, 'Router');
15518    }
15519
15520
155
252
    add_router_acls();
15521
155
269
    prepare_local_optimization();
15522
15523    # No longer needed, free some memory.
15524
155
279
    %expanded_rules = ();
15525
155
207
    %obj2path       = ();
15526
155
162
    %key2obj        = ();
15527
155
130
    return;
15528}
15529
15530##############################################################################
15531# ACL Generation
15532##############################################################################
15533
15534# Returns [ ip, mask ] pair
15535sub address {
15536
2817
0
2315
    my ($obj, $no_nat_set) = @_;
15537
2817
2586
    my $type = ref $obj;
15538
2817
3848
    if ($type eq 'Network') {
15539
2168
2382
        $obj = get_nat_network($obj, $no_nat_set);
15540
15541        # ToDo: Is it OK to permit a dynamic address as destination?
15542
2168
2917
        if ($obj->{ip} eq 'unnumbered') {
15543
0
0
            internal_err("Unexpected unnumbered $obj->{name}");
15544        }
15545        else {
15546
2168
4488
            return [ $obj->{ip}, $obj->{mask} ];
15547        }
15548    }
15549    elsif ($type eq 'Subnet') {
15550
96
141
        my $network = get_nat_network($obj->{network}, $no_nat_set);
15551
96
146
        if (my $nat_tag = $network->{dynamic}) {
15552
2
5
            if (my $ip = $obj->{nat}->{$nat_tag}) {
15553
15554                # Single static NAT IP for this host.
15555
2
4
                return [ $ip, 0xffffffff ];
15556            }
15557            else {
15558
15559                # This has been converted to the  whole network before,
15560                # and hence should never happen.
15561
0
0
                return [ $network->{ip}, $network->{mask} ];
15562            }
15563        }
15564        else {
15565
15566            # Take higher bits from network NAT, lower bits from original IP.
15567            # This works with and without NAT.
15568
94
158
            my $ip =
15569              $network->{ip} | $obj->{ip} & complement_32bit $network->{mask};
15570
94
210
            return [ $ip, $obj->{mask} ];
15571        }
15572    }
15573    elsif ($type eq 'Interface') {
15574
516
1099
        if ($obj->{ip} =~ /^(unnumbered|short)$/) {
15575
0
0
            internal_err("Unexpected $obj->{ip} $obj->{name}");
15576        }
15577
15578
516
673
        my $network = get_nat_network($obj->{network}, $no_nat_set);
15579
15580
516
1054
        if ($obj->{ip} eq 'negotiated') {
15581
2
2
1
4
            my ($network_ip, $network_mask) = @{$network}{ 'ip', 'mask' };
15582
2
4
            return [ $network_ip, $network_mask ];
15583        }
15584        elsif (my $nat_tag = $network->{dynamic}) {
15585
4
12
            if (my $ip = $obj->{nat}->{$nat_tag}) {
15586
15587                # Single static NAT IP for this interface.
15588
3
7
                return [ $ip, 0xffffffff ];
15589            }
15590            else {
15591
15592                # Should never happen.
15593                # aborts with error in mark_dynamic_nat_rules.
15594
1
3
                return [ $network->{ip}, $network->{mask} ];
15595            }
15596        }
15597        else {
15598
15599            # Take higher bits from network NAT, lower bits from original IP.
15600            # This works with and without NAT.
15601
510
785
            my $ip =
15602              $network->{ip} | $obj->{ip} & complement_32bit $network->{mask};
15603
510
1048
            return [ $ip, 0xffffffff ];
15604        }
15605    }
15606    elsif ($type eq 'Objectgroup') {
15607
37
56
        return $obj;
15608    }
15609    else {
15610
0
0
        my $type = ref $obj;
15611
0
0
        internal_err("Unexpected object of type '$type'");
15612    }
15613}
15614
15615# Given an IP and mask, return its address in Cisco syntax.
15616sub cisco_acl_addr {
15617
2086
0
1753
    my ($pair, $model) = @_;
15618
2086
2240
    if (is_objectgroup $pair) {
15619
37
68
        my $keyword =
15620            $model->{filter} eq 'NX-OS' ? 'addrgroup' : 'object-group';
15621
37
94
        return "$keyword $pair->{name}";
15622    }
15623    elsif ($pair->[0] == 0) {
15624
1199
1722
        return "any";
15625    }
15626    elsif ($model->{use_prefix}) {
15627
51
62
        return full_prefix_code($pair);
15628    }
15629    else {
15630
799
795
        my ($ip, $mask) = @$pair;
15631
799
889
        my $ip_code = print_ip($ip);
15632
799
1083
        if ($mask == 0xffffffff) {
15633
289
564
            return "host $ip_code";
15634        }
15635        else {
15636
510
947
            $mask = complement_32bit($mask) if $model->{inversed_acl_mask};
15637
510
559
            my $mask_code = print_ip($mask);
15638
510
1149
            return "$ip_code $mask_code";
15639        }
15640    }
15641}
15642
15643sub ios_route_code {
15644
99
0
97
    my ($pair) = @_;
15645
99
120
    my ($ip, $mask) = @$pair;
15646
99
118
    my $ip_code   = print_ip($ip);
15647
99
130
    my $mask_code = print_ip($mask);
15648
99
198
    return "$ip_code $mask_code";
15649}
15650
15651# Given an IP and mask, return its address
15652# as "x.x.x.x/x" or "x.x.x.x" if prefix == 32.
15653sub prefix_code {
15654
163
0
149
    my ($pair) = @_;
15655
163
157
    my ($ip, $mask) = @$pair;
15656
163
234
    my $ip_code     = print_ip($ip);
15657
163
1102
    my $prefix_code = mask2prefix($mask);
15658
163
463
    return $prefix_code == 32 ? $ip_code : "$ip_code/$prefix_code";
15659}
15660
15661sub full_prefix_code {
15662
69
0
65
    my ($pair) = @_;
15663
69
73
    my ($ip, $mask) = @$pair;
15664
69
79
    my $ip_code     = print_ip($ip);
15665
69
84
    my $prefix_code = mask2prefix($mask);
15666
69
163
    return "$ip_code/$prefix_code";
15667}
15668
15669# Returns 3 values for building a Cisco ACL:
15670# permit <val1> <src> <val2> <dst> <val3>
15671sub cisco_prt_code {
15672
995
0
916
    my ($src_range, $prt, $model) = @_;
15673
995
1038
    my $proto = $prt->{proto};
15674
15675
995
1667
    if ($proto eq 'ip') {
15676
709
1127
        return ('ip', undef, undef);
15677    }
15678    elsif ($proto eq 'tcp' or $proto eq 'udp') {
15679        my $port_code = sub  {
15680
266
251
            my ($range_obj) = @_;
15681
266
266
217
462
            my ($v1, $v2) = @{ $range_obj->{range} };
15682
266
526
            if ($v1 == $v2) {
15683
213
451
                return ("eq $v1");
15684            }
15685            elsif ($v1 == 1 and $v2 == 65535) {
15686
44
61
                return (undef);
15687            }
15688            elsif ($v2 == 65535) {
15689
0
0
                return 'gt ' . ($v1 - 1);
15690            }
15691            elsif ($v1 == 1) {
15692
0
0
                return 'lt ' . ($v2 + 1);
15693            }
15694            else {
15695
9
28
                return ("range $v1 $v2");
15696            }
15697
253
811
        };
15698
253
1265
        my $dst_prt = $port_code->($prt);
15699
253
461
        if (my $established = $prt->{established}) {
15700
33
48
            if (defined $dst_prt) {
15701
0
0
                $dst_prt .= ' established';
15702            }
15703            else {
15704
33
41
                $dst_prt = 'established';
15705            }
15706        }
15707
253
372
        my $src_prt = $src_range && $port_code->($src_range);
15708
253
1310
        return ($proto, $src_prt, $dst_prt);
15709    }
15710    elsif ($proto eq 'icmp') {
15711
28
47
        if (defined(my $type = $prt->{type})) {
15712
24
42
            if (defined(my $code = $prt->{code})) {
15713
0
0
                if ($model->{no_filter_icmp_code}) {
15714
15715                    # PIX can't handle the ICMP code field.
15716                    # If we try to permit e.g. "port unreachable",
15717                    # "unreachable any" could pass the PIX.
15718
0
0
                    return ($proto, undef, $type);
15719                }
15720                else {
15721
0
0
                    return ($proto, undef, "$type $code");
15722                }
15723            }
15724            else {
15725
24
61
                return ($proto, undef, $type);
15726            }
15727        }
15728        else {
15729
4
9
            return ($proto, undef, undef);
15730        }
15731    }
15732    else {
15733
5
10
        return ($proto, undef, undef);
15734    }
15735}
15736
15737# Returns iptables code for filtering a protocol.
15738sub iptables_prt_code {
15739
89
0
79
    my ($src_range, $prt) = @_;
15740
89
91
    my $proto = $prt->{proto};
15741
15742
89
270
    if ($proto eq 'ip') {
15743
0
0
        return '';
15744    }
15745    elsif ($proto eq 'tcp' or $proto eq 'udp') {
15746        my $port_code = sub  {
15747
54
50
            my ($range_obj) = @_;
15748
54
54
44
94
            my ($v1, $v2) = @{ $range_obj->{range} };
15749
54
141
            if ($v1 == $v2) {
15750
26
38
                return $v1;
15751            }
15752            elsif ($v1 == 1 and $v2 == 65535) {
15753
9
16
                return '';
15754            }
15755            elsif ($v2 == 65535) {
15756
0
0
                return "$v1:";
15757            }
15758            elsif ($v1 == 1) {
15759
0
0
                return ":$v2";
15760            }
15761            else {
15762
19
44
                return "$v1:$v2";
15763            }
15764
51
153
        };
15765
51
67
        my $result = "-p $proto";
15766
51
76
        my $sport = $src_range && $port_code->($src_range);
15767
51
68
        $result .= " --sport $sport" if $sport;
15768
51
62
        my $dport = $port_code->($prt);
15769
51
122
        $result .= " --dport $dport" if $dport;
15770
51
237
        return $result;
15771    }
15772    elsif ($proto eq 'icmp') {
15773
30
48
        if (defined(my $type = $prt->{type})) {
15774
22
28
            if (defined(my $code = $prt->{code})) {
15775
0
0
                return "-p $proto --icmp-type $type/$code";
15776            }
15777            else {
15778
22
57
                return "-p $proto --icmp-type $type";
15779            }
15780        }
15781        else {
15782
8
18
            return "-p $proto";
15783        }
15784    }
15785    else {
15786
8
18
        return "-p $proto";
15787    }
15788}
15789
15790sub cisco_acl_line {
15791
506
0
584
    my ($router, $rules_aref, $no_nat_set, $prefix) = @_;
15792
506
479
    my $model       = $router->{model};
15793
506
479
    my $filter_type = $model->{filter};
15794
506
2623
    $filter_type    =~ /^(:?IOS|NX-OS|PIX|ACE)$/
15795        or internal_err("Unknown filter_type $filter_type");
15796
506
424
    my $numbered    = 10;
15797
506
491
    my $active_log  = $router->{log};
15798
506
562
    for my $rule (@$rules_aref) {
15799
995
1518
        print "$model->{comment_char} " . print_rule($rule) . "\n"
15800          if $config{comment_acls};
15801
995
1681
        my ($deny, $src, $dst, $src_range, $prt) =
15802
995
816
          @{$rule}{qw(deny src dst src_range prt)};
15803
995
1284
        my $action = $deny ? 'deny' : 'permit';
15804
995
1276
        my $spair = address($src, $no_nat_set);
15805
995
1198
        my $dpair = address($dst, $no_nat_set);
15806
15807
995
1302
        my ($proto_code, $src_port_code, $dst_port_code) =
15808            cisco_prt_code($src_range, $prt, $model);
15809
995
2043
        my $result = "$prefix $action $proto_code";
15810
995
1346
        $result .= ' ' . cisco_acl_addr($spair, $model);
15811
995
1669
        $result .= " $src_port_code" if defined $src_port_code;
15812
995
1136
        $result .= ' ' . cisco_acl_addr($dpair, $model);
15813
995
1686
        $result .= " $dst_port_code" if defined $dst_port_code;
15814
15815        # Find code for logging.
15816
995
729
        my $log_code;
15817
995
1676
        if ($active_log && (my $log = $rule->{log})) {
15818
20
22
            for my $tag (@$log) {
15819
20
33
                if (exists $active_log->{$tag}) {
15820
18
30
                    if (my $modifier = $active_log->{$tag}) {
15821
16
21
                        my $normalized = $model->{log_modifiers}->{$modifier};
15822
16
21
                        if ($normalized eq ':subst') {
15823
5
7
                            $log_code = $modifier;
15824                        }
15825                        else {
15826
11
16
                            $log_code = "log $normalized";
15827                        }
15828                    }
15829                    else {
15830
2
3
                        $log_code = 'log';
15831                    }
15832
15833                    # Take first of possibly several matching tags.
15834
18
20
                    last;
15835                }
15836            }
15837        }
15838
995
2712
        if ($log_code) {
15839
18
27
            $result .= " $log_code";
15840        }
15841        elsif ($router->{log_deny} && $deny) {
15842
2
3
            $result .= " log";
15843        }
15844
15845        # Add line numbers.
15846
995
1356
        if ($filter_type eq 'NX-OS') {
15847
62
83
            $result = " $numbered$result";
15848
62
63
            $numbered += 10;
15849        }
15850
995
2885
        print "$result\n";
15851    }
15852
506
648
    return;
15853}
15854
15855my $min_object_group_size = 2;
15856
15857sub find_object_groups  {
15858
250
0
241
    my ($router, $hardware) = @_;
15859
250
249
    my $model = $router->{model};
15860
250
246
    my $filter_type = $model->{filter};
15861
250
221
    my $active_log = $router->{log};
15862
250
333
    my $keyword = $filter_type eq 'NX-OS'
15863                ? 'object-group ip address'
15864                : 'object-group network';
15865
15866    # Find identical groups of same size.
15867
250
627
    my $size2first2group_hash = ($router->{size2first2group_hash} ||= {});
15868
250
725
    $router->{vrf_shared_data}->{obj_group_counter} ||= 0;
15869
15870    # Leave 'intf_rules' untouched, because they are handled
15871    # indivually for ASA, PIX.
15872    # NX-OS needs them indivually when optimizing need_protect.
15873
250
280
    for my $rule_type ('rules', 'out_rules') {
15874
500
862
        next if not $hardware->{$rule_type};
15875
15876        # Find object-groups in src / dst of rules.
15877
499
494
        for my $this ('src', 'dst') {
15878
998
1378
            my $that = $this eq 'src' ? 'dst' : 'src';
15879
998
717
            my %group_rule_tree;
15880
15881            # Find groups of rules with identical
15882            # deny, src_range, prt, log, src/dst and different dst/src.
15883
998
998
734
1385
            for my $rule (@{ $hardware->{$rule_type} }) {
15884
549
1293
                my $deny      = $rule->{deny} || '';
15885
549
502
                my $that      = $rule->{$that};
15886
549
490
                my $this      = $rule->{$this};
15887
549
1202
                my $src_range = $rule->{src_range} || '';
15888
549
454
                my $prt       = $rule->{prt};
15889
549
1258
                my $key       = "$deny,$that,$src_range,$prt";
15890
549
828
                if (my $log = $rule->{log}) {
15891
30
29
                    for my $tag (@$log) {
15892
30
60
                        if (defined(my $type = $active_log->{$tag})) {
15893
28
30
                            $key .= ",$type";
15894
28
31
                            last;
15895                        }
15896                    }
15897                }                
15898
549
1585
                $group_rule_tree{$key}->{$this} = $rule;
15899            }
15900
15901            # Find groups >= $min_object_group_size,
15902            # mark rules belonging to one group,
15903            # put groups into an array / hash.
15904
998
1479
            for my $href (values %group_rule_tree) {
15905
15906                # $href is {dst/src => rule, ...}
15907
453
536
                my $size = keys %$href;
15908
453
840
                if ($size >= $min_object_group_size) {
15909
46
93
                    my $glue = {
15910
15911                        # Indicator, that no further rules need
15912                        # to be processed.
15913                        active => 0,
15914
15915                        # NAT map for address calculation.
15916                        no_nat_set => $hardware->{no_nat_set},
15917
15918                        # object-ref => rule, ...
15919                        hash => $href
15920                    };
15921
15922                    # All this rules have identical
15923                    # deny, src_range, prt and dst/src
15924                    # and shall be replaced by a single new rule
15925                    # referencing an object group.
15926
46
63
                    for my $rule (values %$href) {
15927
142
196
                        $rule->{group_glue} = $glue;
15928                    }
15929                }
15930            }
15931
15932            my $calc_ip_mask_strings = sub {
15933
25
27
                my ($keys, $no_nat_set) = @_;
15934
94
158
253
258
                return(map { join('/', @$_) }
15935
94
116
                       sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] }
15936
94
184
                       map { address($_, $no_nat_set) }
15937
25
32
                       map { $ref2obj{$_} || internal_err($_) }
15938                       @$keys);
15939
998
2679
            };
15940
15941            my $build_group = sub {
15942
24
21
                my ($ip_mask_strings) = @_;
15943
24
33
                my $counter = $router->{vrf_shared_data}->{obj_group_counter}++;
15944
15945
92
185
                my $group = new(
15946                    'Objectgroup',
15947                    name       => "g$counter",
15948                    elements   => $ip_mask_strings,
15949
24
46
                    hash       => { map { $_ => 1 } @$ip_mask_strings },
15950                );
15951
15952                # Print object-group.
15953
24
28
                my $numbered = 10;
15954
24
65
                print "$keyword $group->{name}\n";
15955
24
29
                for my $ip_mask ( @$ip_mask_strings ) {
15956
92
190
                    my $pair = [ split '/', $ip_mask ];
15957
15958                    # Reject network with mask = 0 in group.
15959                    # This occurs if optimization didn't work correctly.
15960
92
187
                    $pair->[1] == 0 and
15961                        internal_err("Unexpected object with mask 0",
15962                                     " in object-group of $router->{name}");
15963
92
123
                    my $adr = cisco_acl_addr($pair, $model);
15964
92
182
                    if ($filter_type eq 'NX-OS') {
15965
13
22
                        print " $numbered $adr\n";
15966
13
23
                        $numbered += 10;
15967                    }
15968                    elsif ($filter_type eq 'ACE') {
15969
0
0
                        print " $adr\n";
15970                    }
15971                    else {
15972
79
201
                        print " network-object $adr\n";
15973                    }
15974                }
15975
24
37
                return $group;
15976
998
2486
            };
15977
15978            # Find group with identical elements or define a new one.
15979            my $get_group = sub  {
15980
46
41
                my ($glue)     = @_;
15981
46
42
                my $hash       = $glue->{hash};
15982
46
44
                my $no_nat_set = $glue->{no_nat_set};
15983
15984                # Keys are sorted by their internal address to get
15985                # some "first" element.
15986                # This element is useable for hashing, because addresses
15987                # are known to be fix during program execution.
15988
46
134
                my @keys       = sort keys %$hash;
15989
46
56
                my $first      = $keys[0];
15990
46
44
                my $size       = @keys;
15991
15992                # Find group with identical elements.
15993
46
113
              HASH:
15994
46
40
                for my $group_hash
15995                    (@{ $size2first2group_hash->{$size}->{$first} })
15996                {
15997
22
22
                    my $href = $group_hash->{hash};
15998
15999                    # Check elements for equality.
16000
22
20
                    for my $key (@keys) {
16001
50
97
                        $href->{$key} or next HASH;
16002                    }
16003
16004                    # Found $group_hash with matching elements.
16005                    # Check for existing group in current NAT domain.
16006
22
22
                    my $nat2group = $group_hash->{nat2group};
16007
22
53
                    if (my $group = $nat2group->{$no_nat_set}) {
16008
21
43
                        return $group;
16009                    }
16010
16011
1
11
                    my @ip_mask_strings =
16012                        $calc_ip_mask_strings->(\@keys, $no_nat_set);
16013
16014                    # Check for matching group in other NAT domains.
16015                  GROUP:
16016
1
3
                    for my $group (values %$nat2group) {
16017
1
1
                        my $href = $group->{hash};
16018
16019                        # Check NATed addresses for equality.
16020
1
2
                        for my $key (@ip_mask_strings) {
16021
2
5
                            $href->{$key} or next GROUP;
16022                        }
16023
16024                        # Found matching group.
16025
1
1
                        $nat2group->{$no_nat_set} = $group;
16026
1
3
                        return $group;
16027                    }
16028
16029                    # No group found, build new group.
16030
0
0
                    my $group = $build_group->(\@ip_mask_strings);
16031
0
0
                    $nat2group->{$no_nat_set} = $group;
16032
0
0
                    return $group;
16033                }
16034
16035                # No group hash found, build new group hash with new group.
16036
24
44
                my @ip_mask_strings =
16037                    $calc_ip_mask_strings->(\@keys, $no_nat_set);
16038
24
69
                my $group = $build_group->(\@ip_mask_strings);
16039
24
64
                my $group_hash = {
16040                    hash      => $hash,
16041                    nat2group => { $no_nat_set => $group },
16042                };
16043
24
24
22
44
                push(@{ $size2first2group_hash->{$size}->{$first} },
16044                     $group_hash);
16045
24
50
                return $group;
16046
998
2646
            };
16047
16048            # Build new list of rules using object groups.
16049
998
756
            my @new_rules;
16050
998
998
747
1340
            for my $rule (@{ $hardware->{$rule_type} }) {
16051
16052                # Remove tag, otherwise call to find_object_groups
16053                # for another router would become confused.
16054
549
904
                if (my $glue = delete $rule->{group_glue}) {
16055
16056#              debug(print_rule $rule);
16057
142
209
                    if ($glue->{active}) {
16058
16059#                 debug(" deleted: $glue->{group}->{name}");
16060
96
135
                        next;
16061                    }
16062
46
72
                    my $group = $get_group->($glue);
16063
16064#              debug(" generated: $group->{name}");
16065#              # Only needed when debugging.
16066#              $glue->{group} = $group;
16067
16068
46
51
                    $glue->{active} = 1;
16069
46
83
                    my ($deny, $srcdst, $src_range, $prt, $log) =
16070
46
41
                        @{$rule}{'deny', $that, 'src_range', 'prt', 'log'};
16071
46
95
                    $rule = {
16072                        $that => $srcdst,
16073                        $this => $group,
16074                        prt   => $prt
16075                    };
16076
46
80
                    $rule->{deny}      = $deny      if $deny;
16077
46
65
                    $rule->{src_range} = $src_range if $src_range;
16078
46
73
                    $rule->{log}       = $log       if $log;
16079                }
16080
453
637
                push @new_rules, $rule;
16081            }
16082
998
13777
            $hardware->{$rule_type} = \@new_rules;
16083        }
16084    }
16085
250
404
    return;
16086}
16087
16088# Handle iptables.
16089#
16090sub debug_bintree {
16091
0
0
0
    my ($tree, $depth) = @_;
16092
0
0
    $depth ||= '';
16093
0
0
    my $ip      = print_ip $tree->{ip};
16094
0
0
    my $mask    = print_ip $tree->{mask};
16095
0
0
    my $subtree = $tree->{subtree} ? 'subtree' : '';
16096
16097#    debug($depth, " $ip/$mask $subtree");
16098#    debug_bintree($tree->{lo}, "${depth}l") if $tree->{lo};
16099#    debug_bintree($tree->{hi}, "${depth}h") if $tree->{hi};
16100
0
0
    return;
16101}
16102
16103# Nodes are reverse sorted before being added to bintree.
16104# Redundant nodes are discarded while inserting.
16105# A node with value of sub-tree S is discarded,
16106# if some parent node already has sub-tree S.
16107sub add_bintree;
16108
16109sub add_bintree  {
16110
28
0
29
    my ($tree,    $node)      = @_;
16111
28
28
23
45
    my ($tree_ip, $tree_mask) = @{$tree}{qw(ip mask)};
16112
28
28
23
41
    my ($node_ip, $node_mask) = @{$node}{qw(ip mask)};
16113
28
22
    my $result;
16114
16115    # The case where new node is larger than root node will never
16116    # occur, because nodes are sorted before being added.
16117
16118
28
105
    if ($tree_mask < $node_mask && match_ip($node_ip, $tree_ip, $tree_mask)) {
16119
16120        # Optimization for this special case:
16121        # Root of tree has attribute {subtree} which is identical to
16122        # attribute {subtree} of current node.
16123        # Node is known to be less than root node.
16124        # Hence node together with its subtree can be discarded
16125        # because it is redundant compared to root node.
16126        # ToDo:
16127        # If this optimization had been done before merge_subtrees,
16128        # it could have merged more subtrees.
16129
6
34
        if (   not $tree->{subtree}
16130            or not $node->{subtree}
16131            or $tree->{subtree} ne $node->{subtree})
16132        {
16133
5
8
            my $mask = ($tree_mask >> 1) | 0x80000000;
16134
5
8
            my $branch = match_ip($node_ip, $tree_ip, $mask) ? 'lo' : 'hi';
16135
5
12
            if (my $subtree = $tree->{$branch}) {
16136
4
11
                $tree->{$branch} = add_bintree $subtree, $node;
16137            }
16138            else {
16139
1
2
                $tree->{$branch} = $node;
16140            }
16141        }
16142
6
6
        $result = $tree;
16143    }
16144
16145    # Different nodes with identical IP address.
16146    # This shouldn't occur, because different nodes have already
16147    # been converted to an unique object:
16148    # 1. Different interfaces of redundancy protocols like VRRP or HSRP.
16149    # 2. Dynamic NAT of different networks or hosts to a single address
16150    #    or range.
16151    elsif ($tree_mask == $node_mask && $tree_ip == $node_ip) {
16152
0
0
        my $sub1 = $tree->{subtree} || '';
16153
0
0
        my $sub2 = $node->{subtree} || '';
16154
0
0
        if ($sub1 ne $sub2) {
16155
0
0
            my $ip   = print_ip $tree_ip;
16156
0
0
            my $mask = print_ip $tree_mask;
16157
0
0
            internal_err("Inconsistent rules for iptables for $ip/$mask");
16158        }
16159
0
0
        $result = $tree;
16160    }
16161
16162    # Create common root for tree and node.
16163    else {
16164
22
23
        while (1) {
16165
221
163
            $tree_mask = ($tree_mask & 0x7fffffff) << 1;
16166
221
296
            last if ($node_ip & $tree_mask) == ($tree_ip & $tree_mask);
16167        }
16168
22
34
        $result = new(
16169            'Network',
16170            ip   => ($node_ip & $tree_mask),
16171            mask => $tree_mask
16172        );
16173
22
22
37
39
        @{$result}{qw(lo hi)} =
16174          $node_ip < $tree_ip ? ($node, $tree) : ($tree, $node);
16175    }
16176
16177    # Merge adjacent sub-networks.
16178
28
56
  MERGE:
16179    {
16180
28
22
        $result->{subtree} and last;
16181
26
40
        my $lo = $result->{lo} or last;
16182
26
42
        my $hi = $result->{hi} or last;
16183
26
27
        my $mask = ($result->{mask} >> 1) | 0x80000000;
16184
26
52
        $lo->{mask} == $mask or last;
16185
3
10
        $hi->{mask} == $mask or last;
16186
3
13
        $lo->{subtree} and $hi->{subtree} or last;
16187
3
8
        $lo->{subtree} eq $hi->{subtree} or last;
16188
16189
1
1
        for my $key (qw(lo hi)) {
16190
2
3
            $lo->{$key} and last MERGE;
16191
2
5
            $hi->{$key} and last MERGE;
16192        }
16193
16194#       debug('Merged: ', print_ip $lo->{ip},' ',
16195#             print_ip $hi->{ip},'/',print_ip $hi->{mask});
16196
1
2
        $result->{subtree} = $lo->{subtree};
16197
1
2
        delete $result->{lo};
16198
1
1
        delete $result->{hi};
16199    }
16200
28
69
    return $result;
16201}
16202
16203# Build a binary tree for src/dst objects.
16204sub gen_addr_bintree  {
16205
108
0
104
    my ($elements, $tree, $no_nat_set) = @_;
16206
16207    # Sort in reverse order by mask and then by IP.
16208
28
78
    my @nodes =
16209
132
163
      sort { $b->{mask} <=> $a->{mask} || $b->{ip} <=> $a->{ip} }
16210      map {
16211
108
132
106
95
        my ($ip, $mask) = @{ address($_, $no_nat_set) };
16212
16213        # The tree's node is a simplified network object with
16214        # missing attribute 'name' and extra 'subtree'.
16215
132
294
        new(
16216            'Network',
16217            ip      => $ip,
16218            mask    => $mask,
16219            subtree => $tree->{$_}
16220          )
16221      } @$elements;
16222
108
98
    my $bintree = pop @nodes;
16223
108
200
    while (my $next = pop @nodes) {
16224
24
34
        $bintree = add_bintree $bintree, $next;
16225    }
16226
16227    # Add attribute {noop} to node which doesn't add any test to
16228    # generated rule.
16229
108
178
    $bintree->{noop} = 1 if $bintree->{mask} == 0;
16230
16231#    debug_bintree($bintree);
16232
108
143
    return $bintree;
16233}
16234
16235# Build a tree for src-range/prt objects. Sub-trees for tcp and udp
16236# will be binary trees. Nodes have attributes {proto}, {range},
16237# {type}, {code} like protocols (but without {name}).
16238# Additional attributes for building the tree:
16239# For tcp and udp:
16240# {lo}, {hi} for sub-ranges of current node.
16241# For other protocols:
16242# {seq} an array of ordered nodes for sub protocols of current node.
16243# Elements of {lo} and {hi} or elements of {seq} are guaranteed to be
16244# disjoint.
16245# Additional attribute {subtree} is set with corresponding subtree of
16246# protocol object if current node comes from a rule and wasn't inserted
16247# for optimization.
16248sub gen_prt_bintree  {
16249
101
0
98
    my ($elements, $tree) = @_;
16250
16251
101
80
    my $ip_prt;
16252    my %top_prt;
16253
0
0
    my %sub_prt;
16254
16255    # Add all protocols directly below protocol 'ip' into hash %top_prt
16256    # grouped by protocol.  Add protocols below top protocols or below
16257    # other protocols of current set of protocols to hash %sub_prt.
16258  PRT:
16259
101
115
    for my $prt (@$elements) {
16260
131
134
        my $proto = $prt->{proto};
16261
131
152
        if ($proto eq 'ip') {
16262
12
20
            $ip_prt = $prt;
16263        }
16264        else {
16265
119
103
            my $up = $prt->{up};
16266
16267            # Check if $prt is sub protocol of any other protocol of
16268            # current set. But handle direct sub protocols of 'ip' as
16269            # top protocols.
16270
119
191
            while ($up->{up}) {
16271
61
117
                if (my $subtree = $tree->{$up}) {
16272
16273                    # Found sub protocol of current set.
16274                    # Optimization:
16275                    # Ignore the sub protocol if both protocols
16276                    # have identical subtrees.
16277                    # This happens for different objects having identical IP
16278                    # from NAT or from redundant interfaces.
16279
6
13
                    if ($tree->{$prt} ne $subtree) {
16280
5
5
4
7
                        push @{ $sub_prt{$up} }, $prt;
16281                    }
16282
6
11
                    next PRT;
16283                }
16284
55
106
                $up = $up->{up};
16285            }
16286
16287            # Not a sub protocol (except possibly of IP).
16288
113
225
            my $key = $proto =~ /^\d+$/ ? 'proto' : $proto;
16289
113
113
97
269
            push @{ $top_prt{$key} }, $prt;
16290        }
16291    }
16292
16293    # Collect subtrees for tcp, udp, proto and icmp.
16294
101
93
    my @seq;
16295
16296# Build subtree of tcp and udp protocols.
16297    #
16298    # We need not to handle 'tcp established' because it is only used
16299    # for stateless routers, but iptables is stateful.
16300    my $gen_lohitrees;
16301
0
0
    my $gen_rangetree;
16302    $gen_lohitrees = sub {
16303
143
161
        my ($prt_aref) = @_;
16304
143
230
        if (not $prt_aref) {
16305
65
102
            return (undef, undef);
16306        }
16307        elsif (@$prt_aref == 1) {
16308
69
56
            my $prt = $prt_aref->[0];
16309
69
249
            my ($lo, $hi) = $gen_lohitrees->($sub_prt{$prt});
16310
69
241
            my $node = {
16311                proto   => $prt->{proto},
16312                range   => $prt->{range},
16313                subtree => $tree->{$prt},
16314                lo      => $lo,
16315                hi      => $hi
16316            };
16317
69
118
            return ($node, undef);
16318        }
16319        else {
16320
9
22
            my @ranges =
16321
9
16
              sort { $a->{range}->[0] <=> $b->{range}->[0] } @$prt_aref;
16322
16323            # Split array in two halves.
16324
9
17
            my $mid   = int($#ranges / 2);
16325
9
17
            my $left  = [ @ranges[ 0 .. $mid ] ];
16326
9
15
            my $right = [ @ranges[ $mid + 1 .. $#ranges ] ];
16327
9
28
            return ($gen_rangetree->($left), $gen_rangetree->($right));
16328        }
16329
101
388
    };
16330    $gen_rangetree = sub {
16331
74
65
        my ($prt_aref) = @_;
16332
74
110
        my ($lo, $hi) = $gen_lohitrees->($prt_aref);
16333
74
159
        return $lo if not $hi;
16334
8
8
        my $proto = $lo->{proto};
16335
16336        # Take low port from lower tree and high port from high tree.
16337
8
19
        my $range = [ $lo->{range}->[0], $hi->{range}->[1] ];
16338
16339        # Merge adjacent port ranges.
16340
8
53
        if (    $lo->{range}->[1] + 1 == $hi->{range}->[0]
16341            and $lo->{subtree}
16342            and $hi->{subtree}
16343            and $lo->{subtree} eq $hi->{subtree})
16344        {
16345
12
17
            my @hilo =
16346
3
6
              grep { defined $_ } $lo->{lo}, $lo->{hi}, $hi->{lo}, $hi->{hi};
16347
3
8
            if (@hilo <= 2) {
16348
16349#               debug("Merged: $lo->{range}->[0]-$lo->{range}->[1]",
16350#                     " $hi->{range}->[0]-$hi->{range}->[1]");
16351
2
6
                my $node = {
16352                    proto   => $proto,
16353                    range   => $range,
16354                    subtree => $lo->{subtree}
16355                };
16356
2
4
                $node->{lo} = shift @hilo if @hilo;
16357
2
4
                $node->{hi} = shift @hilo if @hilo;
16358
2
8
                return $node;
16359            }
16360        }
16361        return (
16362            {
16363
6
18
                proto => $proto,
16364                range => $range,
16365                lo    => $lo,
16366                hi    => $hi
16367            }
16368        );
16369
101
284
    };
16370
101
114
    for my $what (qw(tcp udp)) {
16371
202
392
        next if not $top_prt{$what};
16372
56
87
        push @seq, $gen_rangetree->($top_prt{$what});
16373    }
16374
16375# Add single nodes for numeric protocols.
16376
101
173
    if (my $aref = $top_prt{proto}) {
16377
8
0
10
0
        for my $prt (sort { $a->{proto} <=> $b->{proto} } @$aref) {
16378
8
21
            my $node = { proto => $prt->{proto}, subtree => $tree->{$prt} };
16379
8
12
            push @seq, $node;
16380        }
16381    }
16382
16383# Build subtree of icmp protocols.
16384
101
156
    if (my $icmp_aref = $top_prt{icmp}) {
16385
37
28
        my %type2prt;
16386        my $icmp_any;
16387
16388        # If one protocol is 'icmp any' it is the only top protocol,
16389        # all other icmp protocols are sub protocols.
16390
37
69
        if (not defined $icmp_aref->[0]->{type}) {
16391
20
17
            $icmp_any  = $icmp_aref->[0];
16392
20
28
            $icmp_aref = $sub_prt{$icmp_any};
16393        }
16394
16395        # Process icmp protocols having defined type and possibly defined code.
16396        # Group protocols by type.
16397
37
46
        for my $prt (@$icmp_aref) {
16398
21
23
            my $type = $prt->{type};
16399
21
21
17
47
            push @{ $type2prt{$type} }, $prt;
16400        }
16401
16402        # Parameter is array of icmp protocols all having
16403        # the same type and different but defined code.
16404        # Return reference to array of nodes sorted by code.
16405        my $gen_icmp_type_code_sorted = sub {
16406
0
0
            my ($aref) = @_;
16407            [
16408
0
0
                map {
16409
0
0
                    {
16410                        proto   => 'icmp',
16411                        type    => $_->{proto},
16412                        code    => $_->{code},
16413                        subtree => $tree->{$_}
16414                    }
16415                  }
16416
0
0
                  sort { $a->{code} <=> $b->{code} } @$aref
16417            ];
16418
37
105
        };
16419
16420        # For collecting subtrees of icmp subtree.
16421
37
29
        my @seq2;
16422
16423        # Process grouped icmp protocols having the same type.
16424
37
4
71
10
        for my $type (sort { $a <=> $b } keys %type2prt) {
16425
21
21
            my $aref2 = $type2prt{$type};
16426
21
17
            my $node2;
16427
16428            # If there is more than one protocol,
16429            # all have same type and defined code.
16430
21
31
            if (@$aref2 > 1) {
16431
0
0
                my $seq3 = $gen_icmp_type_code_sorted->($aref2);
16432
16433                # Add a node 'icmp type any' as root.
16434
0
0
                $node2 = {
16435                    proto => 'icmp',
16436                    type  => $type,
16437                    seq   => $seq3,
16438                };
16439            }
16440
16441            # One protocol 'icmp type any'.
16442            else {
16443
21
20
                my $prt = $aref2->[0];
16444
21
61
                $node2 = {
16445                    proto   => 'icmp',
16446                    type    => $type,
16447                    subtree => $tree->{$prt}
16448                };
16449
21
47
                if (my $aref3 = $sub_prt{$prt}) {
16450
0
0
                    $node2->{seq} = $gen_icmp_type_code_sorted->($aref3);
16451                }
16452            }
16453
21
38
            push @seq2, $node2;
16454        }
16455
16456        # Add root node for icmp subtree.
16457
37
35
        my $node;
16458
37
58
        if ($icmp_any) {
16459
20
57
            $node = {
16460                proto   => 'icmp',
16461                seq     => \@seq2,
16462                subtree => $tree->{$icmp_any}
16463            };
16464        }
16465        elsif (@seq2 > 1) {
16466
4
8
            $node = { proto => 'icmp', seq => \@seq2 };
16467        }
16468        else {
16469
13
12
            $node = $seq2[0];
16470        }
16471
37
140
        push @seq, $node;
16472    }
16473
16474# Add root node for whole tree.
16475
101
69
    my $bintree;
16476
101
173
    if ($ip_prt) {
16477
12
33
        $bintree = {
16478            proto   => 'ip',
16479            seq     => \@seq,
16480            subtree => $tree->{$ip_prt}
16481        };
16482    }
16483    elsif (@seq > 1) {
16484
8
11
        $bintree = { proto => 'ip', seq => \@seq };
16485    }
16486    else {
16487
81
74
        $bintree = $seq[0];
16488    }
16489
16490    # Add attribute {noop} to node which doesn't need any test in
16491    # generated chain.
16492
101
185
    $bintree->{noop} = 1 if $bintree->{proto} eq 'ip';
16493
101
200
    return $bintree;
16494}
16495
16496my %ref_type = (
16497    src     => \%ref2obj,
16498    dst     => \%ref2obj,
16499    src_prt => \%ref2prt,
16500    prt     => \%ref2prt,
16501);
16502
16503sub find_chains  {
16504
60
0
58
    my ($router, $hardware) = @_;
16505
16506    # For generating names of chains.
16507    # Initialize if called first time.
16508
60
162
    $router->{vrf_shared_data}->{chain_counter} ||= 1;
16509
16510
60
56
    my $no_nat_set = $hardware->{no_nat_set};
16511
60
47
    my $io_rules_hash = $hardware->{io_rules};
16512
60
22
129
46
    my @rule_arefs = map { $io_rules_hash->{$_} } sort keys %$io_rules_hash;
16513
60
59
    my $intf_rules = $hardware->{intf_rules};
16514
60
97
    push @rule_arefs, $intf_rules if $intf_rules;
16515
16516
60
67
    for my $rules (@rule_arefs) {
16517
16518        # Change rules to allow optimization of objects having
16519        # identical IP adress.
16520        # This is crucial for correct operation of sub add_bintree.
16521        # Otherwise internal_err("Inconsistent rules for iptables")
16522        # would be triggered.
16523
43
44
        for my $rule (@$rules) {
16524
16525            # Restore {action} attribute in $rule, so we can handle
16526            # all properties of a rule in unified manner.
16527            # {src_range} attribute is unset for value $prt_ip.
16528            # This needs to be set here, but only for iptables.
16529            # Hence use new attribute {src_prt}.
16530            # $rule needs not to be copied:
16531            # - other device types will ignore this attributes,
16532            # - other linux devices will reuse them.
16533
104
147
            if (!$rule->{action}) {
16534
91
151
                $rule->{action} = $rule->{deny} ? 'deny' : 'permit';
16535
91
84
                my $src_prt = $rule->{src_range};
16536
91
124
                if (not $src_prt) {
16537
91
100
                    my $proto = $rule->{prt}->{proto};
16538
16539                    # Specify protocols tcp, udp, icmp in
16540                    # {src_prt}, to get more efficient chains.
16541
91
158
                    $src_prt = $proto eq 'tcp' ? $prt_tcp->{dst_range}
16542                             : $proto eq 'udp' ? $prt_udp->{dst_range}
16543                             : $proto eq 'icmp' ? $prt_icmp
16544                             : $prt_ip;
16545                }
16546
91
116
                $rule->{src_prt} = $src_prt;
16547            }
16548
16549
104
79
            my $copied;
16550
104
96
            for my $what (qw(src dst)) {
16551
208
206
                my $orig = my $obj = $rule->{$what};
16552
16553                # Loopback interface is converted to loopback network,
16554                # because other networks may have this loopback network
16555                # as value in {is_identical}.
16556
208
358
                if ($obj->{loopback} && (my $network = $obj->{network})) {
16557
8
38
                    if (!($intf_rules && $rules eq $intf_rules &&
16558                          $what eq 'dst'))
16559                    {
16560
2
3
                        $obj = $network;
16561                    }
16562                }
16563
16564                # Identical networks from dynamic NAT and
16565                # from identical aggregates.
16566
208
391
                if (my $identical = $obj->{is_identical}) {
16567
12
26
                    if (my $other = $identical->{$no_nat_set}) {
16568
6
6
                        $obj = $other;
16569                    }
16570                }
16571
16572                # Identical redundancy interfaces.
16573                elsif (my $aref = $obj->{redundancy_interfaces}) {
16574
4
25
                    if (!($intf_rules && $rules eq $intf_rules &&
16575                          $what eq 'dst'))
16576                    {
16577
0
0
                        $obj = $aref->[0];
16578                    }
16579                }
16580
16581
208
539
                $obj eq $orig and next;
16582
16583                # Don't change rules of devices in other NAT domain
16584                # where we may have other {is_identical} relation.
16585
8
36
                $rule = { %$rule } if !$copied++;
16586
8
22
                $rule->{$what} = $obj;
16587            }
16588        }
16589
16590
43
38
        my %cache;
16591
16592        my $print_tree;
16593        $print_tree = sub {
16594
0
0
            my ($tree, $order, $depth) = @_;
16595
0
0
            my $key      = $order->[$depth];
16596
0
0
            my $ref2x    = $ref_type{$key};
16597
0
0
0
0
            my @elements = map { $ref2x->{$_} } keys %$tree;
16598
0
0
            for my $elem (@elements) {
16599
16600#                debug(' ' x $depth, "$elem->{name}");
16601
0
0
                if ($depth < $#$order) {
16602
0
0
                    $print_tree->($tree->{$elem}, $order, $depth + 1);
16603                }
16604            }
16605
43
152
        };
16606
16607        my $insert_bintree = sub {
16608
209
190
            my ($tree, $order, $depth) = @_;
16609
209
210
            my $key      = $order->[$depth];
16610
209
196
            my $ref2x    = $ref_type{$key};
16611
209
263
1265
413
            my @elements = map { $ref2x->{$_} } keys %$tree;
16612
16613            # Put prt/src/dst objects at the root of some subtree into a
16614            # (binary) tree. This is used later to convert subsequent tests
16615            # for ip/mask or port ranges into more efficient nested chains.
16616
209
188
            my $bintree;
16617
209
378
            if ($ref2x eq \%ref2obj) {
16618
108
157
                $bintree = gen_addr_bintree(\@elements, $tree, $no_nat_set);
16619            }
16620            else {    # $ref2x eq \%ref2prt
16621
101
139
                $bintree = gen_prt_bintree(\@elements, $tree);
16622            }
16623
209
715
            return $bintree;
16624
43
118
        };
16625
16626        # Used by $merge_subtrees1 to find identical subtrees.
16627        # Use hash for efficient lookup.
16628
43
35
        my %depth2size2subtrees;
16629        my %subtree2bintree;
16630
16631        # Find and merge identical subtrees.
16632        my $merge_subtrees1 = sub {
16633
147
133
            my ($tree, $order, $depth) = @_;
16634
16635          SUBTREE:
16636
147
187
            for my $subtree (values %$tree) {
16637
174
268
                my @keys = keys %$subtree;
16638
174
177
                my $size = @keys;
16639
16640                # Find subtree with identical keys and values;
16641
174
377
              FIND:
16642
174
135
                for my $subtree2 (@{ $depth2size2subtrees{$depth}->{$size} }) {
16643
36
37
                    for my $key (@keys) {
16644
43
124
                        if (not $subtree2->{$key}
16645                            or $subtree2->{$key} ne $subtree->{$key})
16646                        {
16647
28
50
                            next FIND;
16648                        }
16649                    }
16650
16651                    # Substitute current subtree with found subtree.
16652
8
13
                    $subtree = $subtree2bintree{$subtree2};
16653
8
25
                    next SUBTREE;
16654
16655                }
16656
16657                # Found a new subtree.
16658
166
166
145
218
                push @{ $depth2size2subtrees{$depth}->{$size} }, $subtree;
16659
166
248
                $subtree = $subtree2bintree{$subtree} =
16660                  $insert_bintree->($subtree, $order, $depth + 1);
16661            }
16662
43
125
        };
16663
16664        my $merge_subtrees = sub {
16665
43
44
            my ($tree, $order) = @_;
16666
16667            # Process leaf nodes first.
16668
43
70
            for my $href (values %$tree) {
16669
50
68
                for my $href (values %$href) {
16670
54
74
                    $merge_subtrees1->($href, $order, 2);
16671                }
16672            }
16673
16674            # Process nodes next to leaf nodes.
16675
43
64
            for my $href (values %$tree) {
16676
50
62
                $merge_subtrees1->($href, $order, 1);
16677            }
16678
16679            # Process nodes next to root.
16680
43
65
            $merge_subtrees1->($tree, $order, 0);
16681
43
67
            return $insert_bintree->($tree, $order, 0);
16682
43
111
        };
16683
16684        # Add new chain to current router.
16685        my $new_chain = sub {
16686
36
34
            my ($rules) = @_;
16687
36
51
            my $counter = $router->{vrf_shared_data}->{chain_counter}++;
16688
36
85
            my $chain = new(
16689                'Chain',
16690                name  => "c$counter",
16691                rules => $rules,
16692            );
16693
36
36
36
51
            push @{ $router->{chains} }, $chain;
16694
36
42
            $chain;
16695
43
97
        };
16696
16697
43
35
        my $gen_chain;
16698        $gen_chain = sub {
16699
250
240
            my ($tree, $order, $depth) = @_;
16700
250
230
            my $key = $order->[$depth];
16701
250
176
            my @rules;
16702
16703            # We need the original value later.
16704
250
182
            my $bintree = $tree;
16705
250
184
            while (1) {
16706
297
424
                my ($hi, $lo, $seq, $subtree) =
16707
297
226
                  @{$bintree}{qw(hi lo seq subtree)};
16708
297
528
                $seq = undef if $seq and not @$seq;
16709
297
383
                if (not $seq) {
16710
281
363
                    push @$seq, $hi if $hi;
16711
281
370
                    push @$seq, $lo if $lo;
16712                }
16713
297
386
                if ($subtree) {
16714
16715#                   if($order->[$depth+1]&&
16716#                      $order->[$depth+1] =~ /^(src|dst)$/) {
16717#                       debug($order->[$depth+1]);
16718#                       debug_bintree($subtree);
16719#                   }
16720
258
273
                    my $rules = $cache{$subtree};
16721
258
328
                    if (not $rules) {
16722
209
776
                        $rules =
16723                          $depth + 1 >= @$order
16724                          ? [ { action => $subtree } ]
16725                          : $gen_chain->($subtree, $order, $depth + 1);
16726
209
389
                        if (@$rules > 1 and not $bintree->{noop}) {
16727
9
13
                            my $chain = $new_chain->($rules);
16728
9
18
                            $rules = [ { action => $chain, goto => 1 } ];
16729                        }
16730
209
350
                        $cache{$subtree} = $rules;
16731                    }
16732
16733
258
173
                    my @add_keys;
16734
16735                    # Don't use "goto", if some tests for sub-nodes of
16736                    # $subtree are following.
16737
258
349
                    push @add_keys, (goto => 0)        if $seq;
16738
258
458
                    push @add_keys, ($key => $bintree) if not $bintree->{noop};
16739
258
305
                    if (@add_keys) {
16740
16741                        # Create a copy of each rule because we must not change
16742                        # the original cached rules.
16743
239
819
                        push @rules, map {
16744
239
238
                            { (%$_, @add_keys) }
16745                        } @$rules;
16746                    }
16747                    else {
16748
19
27
                        push @rules, @$rules;
16749                    }
16750                }
16751
297
469
                last if not $seq;
16752
16753                # Take this value in next iteration.
16754
47
39
                $bintree = pop @$seq;
16755
16756                # Process remaining elements.
16757
47
58
                for my $node (@$seq) {
16758
41
119
                    my $rules = $gen_chain->($node, $order, $depth);
16759
41
102
                    push @rules, @$rules;
16760                }
16761            }
16762
250
512
            if (@rules > 1 and not $tree->{noop}) {
16763
16764                # Generate new chain. All elements of @seq are
16765                # known to be disjoint. If one element has matched
16766                # and branched to a chain, then the other elements
16767                # need not be tested again. This is implemented by
16768                # calling the chain using '-g' instead of the usual '-j'.
16769
27
39
                my $chain = $new_chain->(\@rules);
16770
27
73
                return [ { action => $chain, goto => 1, $key => $tree } ];
16771            }
16772            else {
16773
223
314
                return \@rules;
16774            }
16775
43
168
        };
16776
16777        # Build rule trees. Generate and process separate tree for
16778        # adjacent rules with same action.
16779
43
37
        my @rule_trees;
16780        my %tree2order;
16781
43
149
        if ($rules and @$rules) {
16782
43
55
            my $prev_action = $rules->[0]->{action};
16783
16784            # Special rule as marker, that end of rules has been reached.
16785
43
76
            push @$rules, { action => 0 };
16786
43
42
            my $start = my $i = 0;
16787
43
42
            my $last = $#$rules;
16788
43
36
            my %count;
16789
43
35
            while (1) {
16790
147
115
                my $rule = $rules->[$i];
16791
147
133
                my $action = $rule->{action};
16792
147
187
                if ($action eq $prev_action) {
16793
16794                    # Count, which key has the largest number of
16795                    # different values.
16796
104
101
                    for my $what (qw(src dst src_prt prt)) {
16797
416
736
                        $count{$what}{ $rule->{$what} } = 1;
16798                    }
16799
104
105
                    $i++;
16800                }
16801                else {
16802
16803                    # Use key with smaller number of different values
16804                    # first in rule tree. This gives smaller tree and
16805                    # fewer tests in chains.
16806
179
211
                    my @test_order =
16807
43
179
179
76
140
259
                      sort { keys %{ $count{$a} } <=> keys %{ $count{$b} } }
16808                      qw(src_prt dst prt src);
16809
43
35
                    my $rule_tree;
16810
43
46
                    my $end = $i - 1;
16811
43
84
                    for (my $j = $start ; $j <= $end ; $j++) {
16812
104
87
                        my $rule = $rules->[$j];
16813
104
176
                        my ($action, $t1, $t2, $t3, $t4) =
16814
104
85
                          @{$rule}{ 'action', @test_order };
16815
104
427
                        $rule_tree->{$t1}->{$t2}->{$t3}->{$t4} = $action;
16816                    }
16817
43
44
                    push @rule_trees, $rule_tree;
16818
16819#                   debug(join ', ', @test_order);
16820
43
68
                    $tree2order{$rule_tree} = \@test_order;
16821
43
98
                    last if not $action;
16822
0
0
                    $start       = $i;
16823
0
0
                    $prev_action = $action;
16824                }
16825            }
16826
43
194
            @$rules = ();
16827        }
16828
16829
43
81
        for (my $i = 0 ; $i < @rule_trees ; $i++) {
16830
43
41
            my $tree  = $rule_trees[$i];
16831
43
52
            my $order = $tree2order{$tree};
16832
16833#           $print_tree->($tree, $order, 0);
16834
43
124
            $tree = $merge_subtrees->($tree, $order);
16835
43
67
            my $result = $gen_chain->($tree, $order, 0);
16836
16837            # Goto must not be used in last rule of rule tree which is
16838            # not the last tree.
16839
43
82
            if ($i != $#rule_trees) {
16840
0
0
                my $rule = $result->[-1];
16841
0
0
                delete $rule->{goto};
16842            }
16843
16844            # Postprocess rules: Add missing attributes prt, src, dst
16845            # with no-op values.
16846
43
56
            for my $rule (@$result) {
16847
53
114
                $rule->{src} ||= $network_00;
16848
53
95
                $rule->{dst} ||= $network_00;
16849
53
47
                my $prt     = $rule->{prt};
16850
53
50
                my $src_prt = $rule->{src_prt};
16851
53
182
                if (not $prt and not $src_prt) {
16852
4
8
                    $rule->{prt} = $prt_ip;
16853                }
16854                elsif (not $prt) {
16855
2
8
                    $rule->{prt} =
16856                        $src_prt->{proto} eq 'tcp'  ? $prt_tcp->{dst_range}
16857                      : $src_prt->{proto} eq 'udp'  ? $prt_udp->{dst_range}
16858                      : $src_prt->{proto} eq 'icmp' ? $prt_icmp
16859                      :                               $prt_ip;
16860
16861                    # Restore {src_range} from {src_prt}, because
16862                    # {src_range} is only used in find_chains.
16863
2
6
                    $rule->{src_range} = delete $rule->{src_prt}
16864                }
16865            }
16866
43
670
            push @$rules, @$result;
16867        }
16868    }
16869
60
101
    return;
16870}
16871
16872# Print chains of iptables.
16873# Objects have already been normalized to ip/mask pairs.
16874# NAT has already been applied.
16875sub print_chains  {
16876
34
0
34
    my ($router) = @_;
16877
16878    # Declare chain names.
16879
34
34
32
53
    for my $chain (@{ $router->{chains} }) {
16880
36
35
        my $name = $chain->{name};
16881
36
58
        print ":$name -\n";
16882    }
16883
16884    # Define chains.
16885
34
34
33
45
    for my $chain (@{ $router->{chains} }) {
16886
36
36
        my $name   = $chain->{name};
16887
36
40
        my $prefix = "-A $name";
16888
16889#       my $steps = my $accept = my $deny = 0;
16890
36
36
30
43
        for my $rule (@{ $chain->{rules} }) {
16891
75
76
            my $action = $rule->{action};
16892
75
96
            my $action_code =
16893                is_chain($action) ? $action->{name}
16894              : $action eq 'permit' ? 'ACCEPT'
16895              :                       'droplog';
16896
16897            # Calculate maximal number of matches if
16898            # - some rules matches (accept) or
16899            # - all rules don't match (deny).
16900#           $steps += 1;
16901#           if ($action eq 'permit') {
16902#               $accept = max($accept, $steps);
16903#           }
16904#           elsif ($action eq 'deny') {
16905#               $deny = max($deny, $steps);
16906#           }
16907#           elsif ($rule->{goto}) {
16908#               $accept = max($accept, $steps + $action->{a});
16909#           }
16910#           else {
16911#               $accept = max($accept, $steps + $action->{a});
16912#               $steps += $action->{d};
16913#           }
16914
16915
75
110
            my $jump = $rule->{goto} ? '-g' : '-j';
16916
75
90
            my $result = "$jump $action_code";
16917
75
121
            if (my $src = $rule->{src}) {
16918
42
42
37
69
                my $ip_mask = [ @{$src}{qw(ip mask)} ];
16919
42
75
                if ($ip_mask->[1] != 0) {
16920
42
62
                    $result .= ' -s ' . prefix_code($ip_mask);
16921                }
16922            }
16923
75
129
            if (my $dst = $rule->{dst}) {
16924
15
15
12
26
                my $ip_mask = [ @{$dst}{qw(ip mask)} ];
16925
15
29
                if ($ip_mask->[1] != 0) {
16926
15
18
                    $result .= ' -d ' . prefix_code($ip_mask);
16927                }
16928            }
16929          ADD_PROTO:
16930            {
16931
75
75
55
65
                my $src_prt = $rule->{src_prt};
16932
75
63
                my $prt     = $rule->{prt};
16933
75
178
                last ADD_PROTO if not $src_prt and not $prt;
16934
40
124
                last ADD_PROTO if $prt and $prt->{proto} eq 'ip';
16935
40
57
                if (not $prt) {
16936
2
4
                    last ADD_PROTO if $src_prt->{proto} eq 'ip';
16937
2
7
                    $prt =
16938                        $src_prt->{proto} eq 'tcp'  ? $prt_tcp->{dst_range}
16939                      : $src_prt->{proto} eq 'udp'  ? $prt_udp->{dst_range}
16940                      : $src_prt->{proto} eq 'icmp' ? $prt_icmp
16941                      :                               $prt_ip;
16942                }
16943
16944#               debug("c ",print_rule $rule) if not $src_range or not $prt;
16945
40
52
                $result .= ' ' . iptables_prt_code($src_prt, $prt);
16946            }
16947
75
224
            print "$prefix $result\n";
16948        }
16949
16950#       $deny = max($deny, $steps);
16951#       $chain->{a} = $accept;
16952#       $chain->{d} = $deny;
16953#       print "# Max tests: Accept: $accept, Deny: $deny\n";
16954    }
16955
16956    # Empty line as delimiter.
16957
34
39
    print "\n";
16958
34
31
    return;
16959}
16960
16961# Find adjacent port ranges.
16962sub join_ranges  {
16963
514
0
443
    my ($router, $hardware) = @_;
16964
514
374
    my $changed;
16965
514
467
    my $active_log = $router->{log};
16966
514
526
    for my $rules ('intf_rules', 'rules', 'out_rules') {
16967
1542
1366
        my %hash = ();
16968
1542
1985
      RULE:
16969
1542
1094
        for my $rule (@{ $hardware->{$rules} }) {
16970
592
826
            my ($deny, $src, $dst, $src_range, $prt) =
16971
592
484
              @{$rule}{qw(deny src dst src_range prt)};
16972
16973            # Only ranges which have a neighbor may be successfully optimized.
16974            # Currently only dst_ranges are handled.
16975
592
1152
            $prt->{has_neighbor} or next;
16976
16977
90
199
            $deny      ||= '';
16978
90
188
            $src_range ||= '';
16979
90
287
            $hash{$deny}->{$src}->{$dst}->{$src_range}->{$prt} = $rule;
16980        }
16981
16982        # %hash is {deny => href, ...}
16983
1542
2196
        for my $href (values %hash) {
16984
16985            # $href is {src => href, ...}
16986
24
39
            for my $href (values %$href) {
16987
16988                # $href is {dst => href, ...}
16989
36
45
                for my $href (values %$href) {
16990
16991                    # $href is {src_range => href, ...}
16992
70
88
                    for my $src_range_ref (keys %$href) {
16993
70
62
                        my $href = $href->{$src_range_ref};
16994
16995                        # Nothing to do if only a single rule.
16996
70
191
                        next if values %$href == 1;
16997
16998                        # Values of %$href are rules with identical
16999                        # deny/src/dst/src_range and a TCP or UDP protocol.
17000                        #
17001                        # Collect rules with identical log type and
17002                        # identical protocol.
17003
12
11
                        my %key2rules;
17004
12
17
                        for my $rule (values %$href) {
17005
32
35
                            my $key = $rule->{prt}->{proto};
17006
32
51
                            if (my $log = $rule->{log}) {
17007
14
13
                                for my $tag (@$log) {
17008
14
30
                                    if (defined(my $type = $active_log->{$tag}))
17009                                    {
17010
10
11
                                        $key .= ",$type";
17011
10
10
                                        last;
17012                                    }
17013                                }
17014                            }
17015
32
32
26
59
                            push @{ $key2rules{$key} }, $rule;
17016                        }
17017
17018
12
21
                        for my $rules (values %key2rules) {
17019
17020                            # When sorting these rules by low port number,
17021                            # rules with adjacent protocols will placed
17022                            # side by side. There can't be overlaps,
17023                            # because they have been split in function
17024                            # 'order_ranges'.  There can't be sub-ranges,
17025                            # because they have been deleted as redundant
17026                            # above.
17027
14
35
                            my @sorted = sort {
17028
19
29
                                $a->{prt}->{range}->[0]
17029                                <=>
17030                                $b->{prt}->{range}->[0]
17031                            } @$rules;
17032
19
50
                            @sorted >= 2 or next;
17033
11
11
                            my $i      = 0;
17034
11
11
                            my $rule_a = $sorted[$i];
17035
11
11
10
19
                            my ($a1, $a2) = @{ $rule_a->{prt}->{range} };
17036
11
22
                            while (++$i < @sorted) {
17037
13
17
                                my $rule_b = $sorted[$i];
17038
13
13
13
19
                                my ($b1, $b2) = @{ $rule_b->{prt}->{range} };
17039
13
23
                                if ($a2 + 1 == $b1) {
17040
17041                                    # Found adjacent port ranges.
17042
8
24
                                    if (my $range = delete $rule_a->{range}) {
17043
17044                                        # Extend range of previous two or
17045                                        # more elements.
17046
2
1
                                        $range->[1] = $b2;
17047
2
2
                                        $rule_b->{range} = $range;
17048                                    }
17049                                    else {
17050
17051                                        # Combine ranges of $rule_a and $rule_b.
17052
6
13
                                        $rule_b->{range} = [ $a1, $b2 ];
17053                                    }
17054
17055                                    # Mark previous rule as deleted.
17056                                    # Don't use attribute 'deleted', this
17057                                    # may still be set by global
17058                                    # optimization pass.
17059
8
14
                                    $rule_a->{local_del} = 1;
17060
8
8
                                    $changed = 1;
17061                                }
17062
13
10
                                $rule_a = $rule_b;
17063
13
55
                                ($a1, $a2) = ($b1, $b2);
17064                            }
17065                        }
17066                    }
17067                }
17068            }
17069        }
17070
1542
2793
        if ($changed) {
17071
12
13
            my @rules;
17072
12
12
9
24
            for my $rule (@{ $hardware->{$rules} }) {
17073
17074                # Check and remove attribute 'local_del'.
17075
26
41
                next if delete $rule->{local_del};
17076
17077                # Process rules with joined port ranges.
17078                # Remove auxiliary attribute {range} from rules.
17079
18
30
                if (my $range = delete $rule->{range}) {
17080
6
7
                    my $prt   = $rule->{prt};
17081
6
8
                    my $proto = $prt->{proto};
17082
6
13
                    my $key   = join(':', @$range);
17083
17084                    # Try to find existing prt with matching range.
17085                    # This is needed for find_object_groups to work.
17086
6
11
                    my $new_prt = $prt_hash{$proto}->{$key};
17087
6
10
                    unless ($new_prt) {
17088
5
18
                        $new_prt = {
17089                            name  => "joined:$prt->{name}",
17090                            proto => $proto,
17091                            range => $range
17092                        };
17093
5
9
                        $prt_hash{$proto}->{$key} = $new_prt;
17094                    }
17095
6
22
                    my $new_rule = { %$rule, prt => $new_prt };
17096
6
14
                    push @rules, $new_rule;
17097                }
17098                else {
17099
12
17
                    push @rules, $rule;
17100                }
17101            }
17102
12
39
            $hardware->{$rules} = \@rules;
17103        }
17104    }
17105
514
1155
    return;
17106}
17107
17108# Reuse network objects at different interfaces,
17109# so we get reused object-groups.
17110my %filter_networks;
17111
17112sub get_filter_network {
17113
38
0
38
    my ($ip, $mask) = @_;
17114
38
57
    my $key = "$ip/$mask";
17115
38
39
    my $net = $filter_networks{$key};
17116
38
54
    if (!$net) {
17117
14
20
        $net = new('Network', ip => $ip, mask => $mask);
17118
14
16
        $filter_networks{$key} = $net;
17119
14
24
        $ref2obj{$net} = $net;
17120    }
17121
38
76
    return $net;
17122}
17123
17124# Remove rules on device which filters only locally.
17125sub remove_non_local_rules {
17126
514
0
466
    my ($router, $hardware) = @_;
17127
514
1046
    $router->{managed} =~ /^local/ or return;
17128
17129
35
37
    my $no_nat_set = $hardware->{no_nat_set};
17130
35
29
    my $filter_only = $router->{filter_only};
17131
35
36
    for my $rules ('rules', 'out_rules') {
17132
70
48
        my $changed;
17133
70
70
52
105
        for my $rule (@{ $hardware->{$rules} }) {
17134
17135            # Don't remove deny rule
17136
27
41
            next if $rule->{deny};
17137
27
25
            my $both_match = 0;
17138
27
22
            for my $what (qw(src dst)) {
17139
54
56
                my $obj = $rule->{$what};
17140
54
54
39
64
                my ($ip, $mask) = @{ address($obj, $no_nat_set) };
17141
54
71
                for my $pair (@$filter_only) {
17142
56
55
                    my ($i, $m) = @$pair;
17143
17144                    # src/dst matches filter_only or
17145                    # filter_only matches src/dst.
17146
56
119
                    if ($mask > $m && match_ip($ip, $i, $m) ||
17147                        match_ip($i, $ip, $mask))
17148                    {
17149
50
38
                        $both_match++;
17150
50
79
                        last;
17151                    }
17152                }
17153            }
17154
17155            # Either src or dst or both are extern.
17156            # The rule will not be filtered at this device.
17157
27
53
            if ($both_match < 2) {
17158
4
3
                $rule = undef;
17159
4
6
                $changed = 1;
17160            }
17161        }
17162        $changed and
17163
70
6
4
125
10
6
            $hardware->{$rules} = [ grep { $_ } @{ $hardware->{$rules} } ];
17164    }
17165
35
44
    return;
17166}
17167
17168# Add deny and permit rules at device which filters only locally.
17169sub add_local_deny_rules {
17170
514
0
491
    my ($router, $hardware) = @_;
17171
514
1102
    $router->{managed} =~ /^local/ or return;
17172
35
57
    $hardware->{crosslink} and return;
17173
17174
32
28
    my $filter_only = $router->{filter_only};
17175
32
38
34
53
    my @dst_networks = map { get_filter_network(@$_) } @$filter_only;
17176
17177
32
38
    for my $attr (qw(rules out_rules)) {
17178
17179
64
167
        next if $attr eq 'rules' && $hardware->{no_in_acl};
17180
63
163
        next if $attr eq 'out_rules' && ! $hardware->{need_out_acl};
17181
17182        # If attached zone has only one connection to this firewall
17183        # than we don't need to check the source address.  It has
17184        # already been checked, that all networks of this zone match
17185        # {filter_only}.
17186        my $check = sub {
17187
32
53
            $attr eq 'out_rules' and return;
17188
31
31
20
44
            for my $interface (@{ $hardware->{interfaces} }) {
17189
33
32
                my $zone = $interface->{zone};
17190
33
47
                $zone->{zone_cluster} and return;
17191
17192                # Ignore real interface of virtual interface.
17193
69
33
118
37
                my @interfaces = grep({ ! $_->{main_interface} }
17194
33
27
                                      @{ $zone->{interfaces} });
17195
17196
33
66
                if (@interfaces > 1) {
17197
17198
17199                    # Multilpe interfaces belonging to one redundancy
17200                    # group can't be used to cross the zone.
17201
47
40
                    my @redundant =
17202
47
56
                        grep { $_ }
17203
19
19
                        map { $_->{redundancy_interfaces} } @interfaces;
17204
19
64
                    @redundant == @interfaces and equal(@redundant)
17205                        or return;
17206                }
17207            }
17208
16
34
            return 1;
17209
32
95
        };
17210
32
45
        my @src_networks = $check->() ? ($network_00) : @dst_networks;
17211
17212
32
25
        my @filter_rules;
17213
32
32
        for my $src (@src_networks) {
17214
35
30
            for my $dst (@dst_networks) {
17215
44
142
                push(@filter_rules,
17216                     {
17217                         deny => 1,
17218                         src  => $src,
17219                         dst  => $dst,
17220                         prt  => $prt_ip
17221                     });
17222            }
17223        }
17224
32
37
        my $rules = $hardware->{$attr};
17225
32
156
        push @$rules, @filter_rules, $permit_any_rule;
17226    }
17227
32
41
    return;
17228}
17229
17230sub prepare_local_optimization {
17231
17232    # Prepare rules for local_optimization.
17233    # Aggregates with mask 0 are converted to network_00, to be able
17234    # to compare with internally generated rules which use network_00.
17235
155
155
0
150
240
    for my $rule (@{ $expanded_rules{supernet} }) {
17236
105
214
        next if $rule->{deleted} and not $rule->{managed_intf};
17237
104
104
89
150
        my ($src, $dst) = @{$rule}{qw(src dst)};
17238
104
133
        $rule->{src} = $network_00 if is_network($src) && $src->{mask} == 0;
17239
104
136
        $rule->{dst} = $network_00 if is_network($dst) && $dst->{mask} == 0;
17240    }
17241
155
145
    return;
17242}
17243
17244#use Time::HiRes qw ( time );
17245sub local_optimization {
17246
208
0
260
    return if fast_mode();
17247
155
233
    progress('Optimizing locally');
17248
17249    # Needed in find_chains.
17250
155
286
    $ref2obj{$network_00} = $network_00;
17251
17252
155
127
    my %seen;
17253
17254# For debugging only
17255#    my %time;
17256#    my %r2rules;
17257#    my %r2id;
17258#    my %r2del;
17259#    my %r2sec;
17260
155
195
    for my $domain (@natdomains) {
17261
189
201
        my $no_nat_set = $domain->{no_nat_set};
17262
17263        # Subnet relation may be different for each NAT domain,
17264        # therefore it is set up again for each NAT domain.
17265
189
195
        for my $network (@networks) {
17266
841
2434
            next if !$network->{mask} || $network->{mask} == 0;
17267
739
932
            my $up = $network->{is_in}->{$no_nat_set};
17268
739
1588
            if (!$up || $up->{mask} == 0) {
17269
629
499
                $up = $network_00;
17270            }
17271
739
938
            $network->{up} = $up;
17272        }
17273
17274
189
189
190
242
        for my $network (@{ $domain->{networks} }) {
17275
17276            # Iterate over all interfaces attached to current network.
17277            # If interface is virtual tunnel for multiple software clients,
17278            # take separate rules for each software client.
17279
587
2
450
5
            for my $interface (
17280
870
587
1618
753
                map { $_->{id_rules} ? values %{ $_->{id_rules} } : $_ }
17281                @{ $network->{interfaces} })
17282            {
17283
873
789
                my $router           = $interface->{router};
17284
873
1567
                my $managed          = $router->{managed} or next;
17285
615
705
                my $secondary_filter = $managed =~ /secondary$/;
17286
615
605
                my $standard_filter  = $managed eq 'standard';
17287
615
628
                my $do_auth          = $router->{model}->{do_auth};
17288
615
917
                my $hardware =
17289                    $interface->{ip} eq 'tunnel'
17290                  ? $interface
17291                  : $interface->{hardware};
17292
17293                # Do local optimization only once for each hardware interface.
17294
615
1135
                next if $seen{$hardware};
17295
574
828
                $seen{$hardware} = 1;
17296
17297
574
969
                if ($router->{model}->{filter} eq 'iptables') {
17298
60
94
                    find_chains $router, $hardware;
17299
60
130
                    next;
17300                }
17301
17302
514
678
                remove_non_local_rules($router, $hardware);
17303
17304#               my $rname = $router->{name};
17305#               debug("$router->{name}");
17306
514
514
                for my $rules ('intf_rules', 'rules', 'out_rules') {
17307
17308#                    my $t1 = time();
17309
17310                    # For supernet / aggregate rules used in optimization.
17311
1542
1112
                    my %hash;
17312
17313                    # For finding duplicate rules having src or dst
17314                    # which exist as different objects with identical
17315                    # ip address.
17316                    my %id_hash;
17317
17318                    # For finding duplicate secondary rules.
17319
0
0
                    my %id_hash2;
17320
17321
1542
1138
                    my $changed = 0;
17322
1542
1542
1108
2351
                    for my $rule (@{ $hardware->{$rules} }) {
17323
17324                        # Change rule to allow optimization of objects
17325                        # having identical IP address.
17326
571
540
                        for my $what (qw(src dst)) {
17327
1142
1048
                            my $obj = $rule->{$what};
17328
1142
806
                            my $obj_changed;
17329
17330                            # Change loopback interface to loopback network.
17331                            # The loopback network is additionally checked
17332                            # below.
17333
1142
1860
                            if ($obj->{loopback} &&
17334                                (my $network = $obj->{network}))
17335                            {
17336
14
45
                                if (!($rules eq 'intf_rules' && $what eq 'dst'))
17337                                {
17338
8
5
                                    $obj = $network;
17339
8
9
                                    $obj_changed = 1;
17340                                }
17341                            }
17342
17343                            # Identical networks from dynamic NAT and
17344                            # from identical aggregates.
17345
1142
2162
                            if (my $identical = $obj->{is_identical}) {
17346
22
47
                                if (my $other = $identical->{$no_nat_set}) {
17347
19
20
                                    $obj = $other;
17348
19
24
                                    $obj_changed = 1;
17349                                }
17350                            }
17351
17352                            # Identical redundancy interfaces.
17353                            elsif (my $aref = $obj->{redundancy_interfaces}) {
17354
13
40
                                if (
17355                                    !($rules eq 'intf_rules' && $what eq 'dst')
17356                                    || (   $router->{crosslink_intf_hash}
17357                                        && $router->{crosslink_intf_hash}
17358                                        ->{ $aref->[0] })
17359                                  )
17360                                {
17361
11
11
                                    $obj = $aref->[0];
17362
11
9
                                    $obj_changed = 1;
17363                                }
17364                            }
17365
17366
1142
1978
                            $obj_changed or next;
17367
17368                            # Don't change rules of devices in other
17369                            # NAT domain where we may have other
17370                            # relation.
17371
38
190
                            $rule = { %$rule, $what => $obj };
17372                        }
17373
571
835
                        my ($src, $dst, $deny, $src_range, $prt) =
17374
571
555
                          @{$rule}{qw(src dst deny src_range prt)};
17375
571
1373
                        $deny      ||= '';
17376
571
1199
                        $src_range ||= $prt_ip;
17377
17378                        # Remove duplicate rules.
17379
571
2084
                        if ($id_hash{$deny}->{$src_range}->{$src}->{$dst}
17380                            ->{$prt})
17381                        {
17382
43
40
                            $rule    = undef;
17383
43
57
                            $changed = 1;
17384
17385#                            $r2id{$rname}++;
17386
43
74
                            next;
17387                        }
17388
528
1630
                        $id_hash{$deny}->{$src_range}->{$src}->{$dst}
17389                          ->{$prt} = $rule;
17390
17391
528
2438
                        if (   $src->{is_supernet}
17392                            || $dst->{is_supernet}
17393                            || $rule->{stateless})
17394                        {
17395
188
805
                            $hash{$deny}->{$src_range}->{$src}->{$dst}
17396                              ->{$prt} = $rule;
17397                        }
17398                    }
17399
17400#                    my $t2 = time();
17401#                    $time{$rname}[0] += $t2-$t1;
17402                  RULE:
17403
1542
1542
1237
1863
                    for my $rule (@{ $hardware->{$rules} }) {
17404
571
843
                        next if not $rule;
17405
17406#                        my $t3 = time();
17407#                        $r2rules{$rname}++;
17408
17409#                       debug(print_rule $rule);
17410#                       debug "is_supernet" if $rule->{dst}->{is_supernet};
17411
528
827
                        my ($deny, $src, $dst, $src_range, $prt, $log) =
17412
528
428
                          @{$rule}{qw(deny src dst src_range prt log)};
17413
528
1271
                        $deny      ||= '';
17414
528
1105
                        $src_range ||= $prt_ip;
17415
528
1124
                        $log       ||= '';
17416
17417
528
375
                        while (1) {
17418
1044
800
                         my $src_range = $src_range;
17419
1044
1549
                         if (my $hash = $hash{$deny}) {
17420
253
179
                          while (1) {
17421
267
211
                           my $src = $src;
17422
267
515
                           if (my $hash = $hash->{$src_range}) {
17423
253
190
                            while (1) {
17424
507
364
                             my $dst = $dst;
17425
507
874
                             if (my $hash = $hash->{$src}) {
17426
258
206
                              while (1) {
17427
524
382
                               my $prt = $prt;
17428
524
895
                               if (my $hash = $hash->{$dst}) {
17429
260
211
                                while (1) {
17430
676
1073
                                 if (my $other_rule = $hash->{$prt}) {
17431
203
530
                                  my $o_log = $other_rule->{log} || '';
17432
203
530
                                  if ($rule ne $other_rule && $log eq $o_log) {
17433
17434#                                  debug("del:", print_rule $rule);
17435#                                  debug("oth:", print_rule $other_rule);
17436
12
10
                                   $rule = undef;
17437
17438#                                  $r2del{$rname}++;
17439
12
11
                                   $changed = 1;
17440
17441#                                  $time{$rname}[1] += time()-$t3;
17442
12
44
                                   next RULE;
17443                                  }
17444                                 }
17445
664
1042
                                 $prt = $prt->{up} or last;
17446                                }
17447                               }
17448
512
825
                               $dst = $dst->{up} or last;
17449                              }
17450                             }
17451
495
791
                             $src = $src->{up} or last;
17452                            }
17453                           }
17454
255
456
                           $src_range = $src_range->{up} or last;
17455                          }
17456                         }
17457
1032
1385
                         last if $deny;
17458
516
441
                         $deny = 1;
17459                        }
17460
17461#                        my $t4 = time();
17462#                        $time{$rname}[1] += $t4-$t3;
17463
17464                        # Implement remaining rules as secondary rule,
17465                        # if possible.
17466
516
2544
                        if (   $secondary_filter && $rule->{some_non_secondary}
17467                            || $standard_filter && $rule->{some_primary})
17468                        {
17469
15
28
                            $rule->{deny} and internal_err();
17470
15
15
17
21
                            my ($src, $dst) = @{$rule}{qw(src dst)};
17471
17472                            # Replace obj by largest supernet in zone,
17473                            # which has no subnet in other zone.
17474                            # We must not change to network having subnet in
17475                            # other zone, because then we had to do
17476                            # check_supernet_rules for newly created
17477                            # secondary rules.
17478
15
26
                            for my $ref (\$src, \$dst) {
17479
17480                                # Restrict secondary optimization at
17481                                # authenticating router to prevent
17482                                # unauthorized access with spoofed IP
17483                                # address.
17484
30
51
                                if ($do_auth) {
17485
0
0
                                    my $type = ref($$ref);
17486
17487                                    # Single ID-hosts must not be
17488                                    # converted to network.
17489
0
0
                                    if ($type eq 'Subnet') {
17490
0
0
                                        next if $$ref->{id};
17491                                    }
17492
17493                                    # Network with ID-hosts must not
17494                                    # be optimized at all.
17495                                    elsif ($type eq 'Network') {
17496
0
0
                                        next RULE if $$ref->{has_id_hosts};
17497                                    }
17498                                }
17499
30
86
                                if (
17500                                       $$ref eq $dst
17501                                    && is_interface($dst)
17502                                    && (
17503                                        $dst->{router} eq $router
17504                                        || (    $router->{crosslink_intf_hash}
17505                                            and $router->{crosslink_intf_hash}
17506                                            ->{$dst})
17507                                    )
17508                                  )
17509                                {
17510
1
2
                                    next;
17511                                }
17512
29
45
                                if (is_subnet($$ref) || is_interface($$ref)) {
17513
7
9
                                    my $net = $$ref->{network};
17514
7
17
                                    next if $net->{has_other_subnet};
17515
4
5
                                    $$ref = $net;
17516                                }
17517
26
50
                                if (my $max = $$ref->{max_secondary_net}) {
17518
3
5
                                    $$ref = $max;
17519                                }
17520
17521                                # Prevent duplicate ACLs for networks which
17522                                # are translated to the same ip address.
17523
26
56
                                if (my $identical = $$ref->{is_identical}) {
17524
0
0
                                    if (my $one_net = $identical->{$no_nat_set})
17525                                    {
17526
0
0
                                        $$ref = $one_net;
17527                                    }
17528                                }
17529                            }
17530
17531                            # Add new rule to hash. If there are multiple
17532                            # rules which could be converted to the same
17533                            # secondary rule, only the first one will be
17534                            # generated.
17535
15
46
                            if (my $old = $id_hash2{$src}->{$dst}) {
17536
17537
0
0
                                if ($old ne $rule) {
17538
17539#                                   debug("sec delete: ", print_rule $rule);
17540
17541
0
0
                                    $rule    = undef;
17542
0
0
                                    $changed = 1;
17543
17544#                                    $r2sec{$rname}++;
17545                                }
17546                            }
17547                            else {
17548
17549                                # Don't modify original rule, because the
17550                                # identical rule is referenced at different
17551                                # routers.
17552
15
32
                                my $new_rule = {
17553                                    src       => $src,
17554                                    dst       => $dst,
17555                                    prt       => $prt_ip,
17556                                };
17557
15
30
                                $new_rule->{log} = $rule->{log} if $rule->{log};
17558
17559#                               debug("sec: ", print_rule $new_rule);
17560
15
28
                                $id_hash2{$src}->{$dst} = $new_rule;
17561
17562                                # This only works if smaller rule isn't
17563                                # already processed.
17564
15
47
                                if ($src->{is_supernet} || $dst->{is_supernet})
17565                                {
17566
8
29
                                    $hash{''}->{$prt_ip}->{$src}->{$dst}
17567                                      ->{$prt_ip} = $new_rule;
17568                                }
17569
17570                                # This changes @{$hardware->{$rules}} !
17571
15
33
                                $rule = $new_rule;
17572                            }
17573                        }
17574
17575#                        my $t5 = time();
17576#                        $time{$rname}[2] += $t5-$t4;
17577                    }
17578
1542
3426
                    if ($changed) {
17579
113
288
                        $hardware->{$rules} =
17580
38
38
43
59
                          [ grep { defined $_ } @{ $hardware->{$rules} } ];
17581                    }
17582                }
17583
17584
514
761
                add_local_deny_rules($router, $hardware);
17585
17586                # Join adjacent port ranges.  This must be called after local
17587                # optimization has been finished, because protocols will be
17588                # overlapping again after joining.
17589#                my $t6 = time();
17590
514
631
                join_ranges($router, $hardware);
17591
17592#                $time{$rname}[3] += time() - $t6;
17593            }
17594        }
17595    }
17596
17597#    my ($orules, $oid, $odel, $osec, $arules, $aid, $adel, $asec,
17598#        @otime, @atime);
17599#    my $f = '%-12s %7i %7i %7i %7i %.3f %.3f %.3f %.3f %.3f';
17600#    for my $aref (values %time) {
17601#        $aref->[4] = $aref->[0] + $aref->[1] + $aref->[2] + $aref->[3];
17602#        $atime[0] += $aref->[0];
17603#        $atime[1] += $aref->[1];
17604#        $atime[2] += $aref->[2];
17605#        $atime[3] += $aref->[3];
17606#        $atime[4] += $aref->[4];
17607#    }
17608#    for my $name (sort { $time{$a}[4] <=> $time{$b}[4] } keys %time) {
17609#        my $pre = $time{$name}[0];
17610#        my $while = $time{$name}[1];
17611#        my $secon = $time{$name}[2];
17612#        my $join = $time{$name}[3];
17613#        my $sum = $time{$name}[4];
17614#        my $rules = $r2rules{$name};
17615#        my $id = $r2id{$name} || 0;
17616#        my $del = $r2del{$name} || 0;
17617#        my $sec = $r2sec{$name} || 0;
17618#        $arules += $rules;
17619#        $aid += $id;
17620#        $adel += $del;
17621#        $asec += $sec;
17622#        if ($sum < 0.5) {
17623#            $otime[0] += $pre;
17624#            $otime[1] += $while;
17625#            $otime[2] += $secon;
17626#            $otime[3] += $join;
17627#            $otime[4] += $sum;
17628#            $orules += $rules;
17629#            $odel += $del;
17630#            $oid += $id;
17631#            $osec += $sec;
17632#        }
17633#        else {
17634#            $name =~ s/^router://;
17635#            debug(sprintf( $f, $name, $rules, $id, $del, $sec,
17636#                           $pre, $while, $secon, $join, $sum));
17637#        }
17638#    }
17639#    debug(sprintf( $f, 'other', $orules, $oid, $odel, $osec,
17640#                   $otime[0], $otime[1], $otime[2], $otime[3], $otime[4]));
17641#    debug(sprintf( $f, 'all', $arules, $aid, $adel, $asec,
17642#                   $atime[0], $atime[1], $atime[2], $atime[3], $atime[4]));
17643
17644
155
268
    return;
17645}
17646
17647my $deny_any_rule;
17648
17649sub print_cisco_acl_add_deny {
17650
481
0
582
    my ($router, $hardware, $no_nat_set, $model, $prefix) = @_;
17651
481
357
    my $permit_any;
17652
17653
481
785
    my $rules = $hardware->{rules} ||= [];
17654
481
705
    if (@$rules) {
17655
235
402
        my ($deny, $src, $dst, $prt) =
17656
235
210
          @{ $rules->[-1] }{ 'deny', 'src', 'dst', 'prt' };
17657
235
548
        $permit_any =
17658             !$deny
17659          && is_network($src)
17660          && $src->{mask} == 0
17661          && is_network($dst)
17662          && $dst->{mask} == 0
17663          && $prt eq $prt_ip;
17664    }
17665
17666    # Add permit or deny rule at end of ACL
17667    # unless the previous rule is 'permit ip any any'.
17668
481
703
    if (!$permit_any) {
17669
447
852
        push(
17670
447
343
            @{ $hardware->{rules} },
17671            $hardware->{no_in_acl} ? $permit_any_rule : $deny_any_rule
17672        );
17673
447
459
        $permit_any = $hardware->{no_in_acl};
17674    }
17675
17676
481
1161
    if ($router->{need_protect} ||
17677
17678        # ASA protects IOS router behind crosslink interface.
17679        $router->{crosslink_intf_hash})
17680    {
17681
17682        # Routers connected by crosslink networks are handled like one
17683        # large router. Protect the collected interfaces of the whole
17684        # cluster at each entry.
17685
280
251
        my $interfaces = $router->{crosslink_interfaces};
17686
280
405
        if (!$interfaces) {
17687
262
239
            $interfaces = $router->{interfaces};
17688
262
403
            if ($model->{has_vip}) {
17689
7
15
10
28
                $interfaces = [ grep { !$_->{vip} } @$interfaces ];
17690            }
17691        }
17692
17693        # Set crosslink_intf_hash even for routers not part of a
17694        # crosslink cluster.
17695
304
693
        $router->{crosslink_intf_hash} ||=
17696
280
113
502
142
          { map { $_ => $_ } @{ $router->{interfaces} } };
17697
280
274
        my $intf_hash = $router->{crosslink_intf_hash};
17698
17699        # Add deny rules to protect own interfaces.
17700        # If a rule permits traffic to a directly connected network
17701        # behind the device, this would accidently permit traffic
17702        # to an interface of this device as well.
17703
17704        # Deny rule is needless if there is a rule which permits any
17705        # traffic to the interface or
17706        # to one interface of a redundancy group.
17707        # The permit rule can be deleted if there is a permit any any rule.
17708
280
214
        my %no_protect;
17709        my %seen;
17710
0
0
        my $changed;
17711
280
280
225
404
        for my $rule (@{ $hardware->{intf_rules} }) {
17712
62
102
            next if $rule->{deny};
17713
62
54
            my $src = $rule->{src};
17714
62
78
            next if not is_network($src);
17715
53
125
            next if $src->{mask} != 0;
17716
18
42
            next if $rule->{prt} ne $prt_ip;
17717
9
10
            my $dst = $rule->{dst};
17718
9
24
            $no_protect{$dst} = 1 if $intf_hash->{$dst};
17719
9
14
            $seen{ $dst->{redundancy_interfaces} }++
17720              if $dst->{redundancy_interfaces};
17721
17722
9
21
            if ($permit_any) {
17723
5
4
                $rule    = undef;
17724
5
15
                $changed = 1;
17725            }
17726        }
17727
280
415
        if ($changed) {
17728
5
8
            $hardware->{intf_rules} =
17729
3
3
4
5
              [ grep { defined $_ } @{ $hardware->{intf_rules} } ];
17730        }
17731
17732        # Deny rule is needless if there is no such permit rule.
17733        # Try to optimize this case.
17734
280
211
        my %need_protect;
17735        my $protect_all;
17736
280
432
        my $local_filter = $router->{managed} =~ /^local/;
17737        my $check_intf = sub {
17738
97
97
            my ($ip, $mask) = @_;
17739
97
161
            for my $intf (values %$intf_hash) {
17740
247
573
                next if $intf->{ip} =~
17741                        /^(unnumbered|negotiated|tunnel|bridged)$/;
17742
239
275
                my $i = address($intf, $no_nat_set)->[0];
17743
239
338
                if (match_ip($i, $ip, $mask)) {
17744
84
203
                    $need_protect{$intf} = $intf;
17745
17746#                   debug("Protect $intf->{name} at $hardware->{name}");
17747                }
17748            }
17749
280
879
        };
17750
280
353
      RULE:
17751
280
262
        for my $rule (@{ $hardware->{rules} }) {
17752
428
843
            next if $rule->{deny};
17753
165
284
            next if $rule->{prt}->{established};
17754
17755            # Ignore permit_any_rule of local filter.
17756            # Some other permit_any_rule from a real service
17757            # wouldn't match.
17758
140
312
            next if $local_filter && $rule eq $permit_any_rule;
17759
133
116
            my $dst = $rule->{dst};
17760
17761            # We only need to check networks:
17762            # - subnet/host and interface already have been checked to
17763            #   have disjoint ip addresses to interfaces of current router.
17764
133
187
            if (is_objectgroup($dst)) {
17765
1
2
                my $elements = $dst->{elements};
17766
1
1
                for my $ip_mask ( @$elements ) {
17767
3
7
                    my ($ip, $mask) = split '/', $ip_mask;
17768
3
7
                    next if $mask == 0xffffffff;
17769
3
4
                    $check_intf->($ip, $mask);
17770                }
17771            }
17772            elsif (is_network($dst)) {
17773
111
196
                if ($dst->{mask} == 0) {
17774
17
16
                    $protect_all = 1;
17775
17776#                   debug("Protect all $router->{name}: $hardware->{name}");
17777
17
27
                    last RULE;
17778                }
17779
17780
94
94
85
128
                my ($ip, $mask) = @{ address($dst, $no_nat_set) };
17781
94
159
                $check_intf->($ip, $mask);
17782            }
17783        }
17784
17785
280
342
        for my $interface (@$interfaces) {
17786
818
4411
            if (
17787                $no_protect{$interface}
17788                or not $protect_all
17789                and not $need_protect{$interface}
17790
17791                # Interface with 'no_in_acl' gets 'permit any any' added
17792                # and hence needs deny rules.
17793                and not $hardware->{no_in_acl}
17794              )
17795            {
17796
700
824
                next;
17797            }
17798
17799            # Ignore 'unnumbered' interfaces.
17800
118
272
            if ($interface->{ip} =~
17801                /^(?:unnumbered|negotiated|tunnel|bridged)$/)
17802            {
17803
0
0
                next;
17804            }
17805
118
191
            internal_err("Managed router has short $interface->{name}")
17806              if $interface->{ip} eq 'short';
17807
17808            # IP of other interface may be unknown if dynamic NAT is used.
17809
118
231
            if ($interface->{hardware} ne $hardware) {
17810
100
140
                my $nat_network =
17811                  get_nat_network($interface->{network}, $no_nat_set);
17812
100
184
                next if $nat_network->{dynamic};
17813            }
17814
118
236
            if (    $interface->{redundancy_interfaces}
17815                and $seen{ $interface->{redundancy_interfaces} }++)
17816            {
17817
0
0
                next;
17818            }
17819
17820            # Protect own interfaces.
17821
118
118
101
390
            push @{ $hardware->{intf_rules} },
17822              {
17823                deny      => 1,
17824                src       => $network_00,
17825                dst       => $interface,
17826                prt       => $prt_ip
17827              };
17828        }
17829
280
1329
        if ($hardware->{crosslink}) {
17830
2
8
            $hardware->{intf_rules} = [];
17831        }
17832    }
17833
17834    # ASA and PIX ignore rules for own interfaces.
17835    else {
17836
201
275
      $hardware->{intf_rules} = [];
17837    }  
17838
17839    # Concatenate interface rules and ordinary rules.
17840
481
502
    my $intf_rules = $hardware->{intf_rules};
17841
481
708
    my $all_rules = @$intf_rules? [ @$intf_rules, @$rules ] : $rules;
17842
481
697
    cisco_acl_line($router, $all_rules, $no_nat_set, $prefix);
17843
481
604
    return;
17844}
17845
17846# Parameter: Interface
17847# Analyzes dst of all rules collected at this interface.
17848# Result:
17849# Array reference to list of all networks which are allowed
17850# to pass this interface.
17851sub get_split_tunnel_nets {
17852
4
0
4
    my ($interface) = @_;
17853
17854
4
4
    my %split_tunnel_nets;
17855
4
4
4
3
5
7
    for my $rule (@{ $interface->{rules} }, @{ $interface->{intf_rules} }) {
17856
11
16
        next if $rule->{deny};
17857
11
15
        my $dst = $rule->{dst};
17858
11
12
        my $dst_network = is_network($dst) ? $dst : $dst->{network};
17859
17860        # Dont add 'any' (resulting from global:permit)
17861        # to split_tunnel networks.
17862
11
18
        next if $dst_network->{mask} == 0;
17863
10
20
        $split_tunnel_nets{$dst_network} = $dst_network;
17864    }
17865
4
5
10
14
    return [ sort { $a->{ip} <=> $b->{ip} || $a->{mask} <=> $b->{mask} }
17866          values %split_tunnel_nets ];
17867}
17868
17869my %asa_vpn_attr_need_value =
17870    map { $_ => 1 }
17871qw(banner dns-server default-domain split-dns wins-server address-pools
17872   split-tunnel-network-list vpn-filter);
17873
17874sub print_asavpn  {
17875
3
0
3
    my ($router)         = @_;
17876
3
4
    my $model            = $router->{model};
17877
3
5
    my $no_nat_set       = $router->{hardware}->[0]->{no_nat_set};
17878
17879
3
2
    my $global_group_name = 'global';
17880
3
7
    print <<"EOF";
17881group-policy $global_group_name internal
17882group-policy $global_group_name attributes
17883 pfs enable
17884
17885EOF
17886
17887    # Define tunnel group used for single VPN users.
17888
3
3
    my $default_tunnel_group = 'VPN-single';
17889
3
4
    my $trust_point = $router->{trust_point};
17890
17891
3
15
    print <<"EOF";
17892tunnel-group $default_tunnel_group type remote-access
17893tunnel-group $default_tunnel_group general-attributes
17894 authorization-server-group LOCAL
17895 default-group-policy $global_group_name
17896 authorization-required
17897 username-from-certificate EA
17898tunnel-group $default_tunnel_group ipsec-attributes
17899 chain
17900EOF
17901
17902
3
4
    if ($model->{v8_4}) {
17903
0
0
        print <<"EOF";
17904 ikev1 trust-point $trust_point
17905 ikev1 user-authentication none
17906tunnel-group $default_tunnel_group webvpn-attributes
17907 authentication certificate
17908EOF
17909    }
17910    else {
17911
3
9
        print <<"EOF";
17912 trust-point $trust_point
17913 isakmp ikev1-user-authentication none
17914EOF
17915    }
17916
3
4
    print <<"EOF";
17917tunnel-group-map default-group $default_tunnel_group
17918
17919EOF
17920
17921    my $print_group_policy = sub {
17922
4
4
        my ($name, $attributes) = @_;
17923
4
8
        print "group-policy $name internal\n";
17924
4
5
        print "group-policy $name attributes\n";
17925
4
12
        for my $key (sort keys %$attributes) {
17926
10
12
            my $value = $attributes->{$key};
17927
10
10
            my $out = $key;
17928
10
12
            if (defined($value)) {
17929
10
20
                $out .= ' value' if $asa_vpn_attr_need_value{$key};
17930
10
13
                $out .= " $value";
17931            }
17932
10
22
            print " $out\n";
17933        }
17934
3
13
    };
17935
17936
3
4
    my %cert_group_map;
17937    my %single_cert_map;
17938
3
3
    my $user_counter = 0;
17939
3
3
3
4
    for my $interface (@{ $router->{interfaces} }) {
17940
8
14
        next if not $interface->{ip} eq 'tunnel';
17941
3
3
        my %split_t_cache;
17942
17943
3
5
        if (my $hash = $interface->{id_rules}) {
17944
2
11
            for my $id (sort keys %$hash) {
17945
5
6
                my $id_intf = $hash->{$id};
17946
5
5
                my $src     = $id_intf->{src};
17947
5
4
                $user_counter++;
17948
5
5
                my $pool_name;
17949
5
8
                my $attributes = {
17950
5
8
                    %{ $router->{radius_attributes} },
17951
5
15
                    %{ $src->{network}->{radius_attributes} },
17952
5
3
                    %{ $src->{radius_attributes} },
17953                };
17954
17955                # Define split tunnel ACL.
17956                # Use default value if not defined.
17957
5
6
                my $split_tunnel_policy = $attributes->{'split-tunnel-policy'};
17958
5
10
                if (not defined $split_tunnel_policy) {
17959
17960                    # Do nothing.
17961                }
17962                elsif ($split_tunnel_policy eq 'tunnelall') {
17963
17964                    # This is the default value.
17965                    # Prevent new group-policy to be created.
17966
0
0
                    delete $attributes->{'split-tunnel-policy'};
17967                }
17968                elsif ($split_tunnel_policy eq 'tunnelspecified') {
17969
1
3
                    my $split_tunnel_nets = get_split_tunnel_nets($id_intf);
17970
1
2
                    my $acl_name;
17971
1
3
                    if (my $href = $split_t_cache{@$split_tunnel_nets}) {
17972                      CACHED_NETS:
17973
0
0
                        for my $cached_name (keys %$href) {
17974
0
0
                            my $cached_nets = $href->{$cached_name};
17975
0
0
                            for (my $i = 0 ; $i < @$cached_nets ; $i++) {
17976
0
0
                                if ($split_tunnel_nets->[$i] ne
17977                                    $cached_nets->[$i])
17978                                {
17979
0
0
                                    next CACHED_NETS;
17980                                }
17981                            }
17982
0
0
                            $acl_name = $cached_name;
17983
0
0
                            last;
17984                        }
17985                    }
17986
1
2
                    if (not $acl_name) {
17987
1
1
                        $acl_name = "split-tunnel-$user_counter";
17988
1
2
                        if (@$split_tunnel_nets) {
17989
1
2
                            for my $network (@$split_tunnel_nets) {
17990
4
6
                                my $line =
17991                                  "access-list $acl_name standard permit ";
17992
4
5
                                $line .=
17993                                  cisco_acl_addr(address($network,
17994                                                         $no_nat_set),
17995                                                 $model);
17996
4
10
                                print "$line\n";
17997                            }
17998                        }
17999                        else {
18000
0
0
                            print "access-list $acl_name standard deny any\n";
18001                        }
18002
1
3
                        $split_t_cache{@$split_tunnel_nets}->{$acl_name} =
18003                          $split_tunnel_nets;
18004                    }
18005
1
2
                    $attributes->{'split-tunnel-network-list'} = $acl_name;
18006                }
18007
18008                # Access list will be bound to cleartext interface.
18009                # Only check for valid source address at vpn-filter.
18010
5
7
                $id_intf->{intf_rules} = [];
18011
5
11
                $id_intf->{rules}      = [
18012                    {
18013                        src       => $src,
18014                        dst       => $network_00,
18015                        prt       => $prt_ip,
18016                    }
18017                ];
18018
5
12
                find_object_groups($router, $id_intf);
18019
18020                # Define filter ACL to be used in username or group-policy.
18021
5
7
                my $filter_name = "vpn-filter-$user_counter";
18022
5
8
                my $prefix      = "access-list $filter_name extended";
18023
5
9
                print_cisco_acl_add_deny $router, $id_intf, $no_nat_set, $model,
18024                  $prefix;
18025
18026
5
5
                my $ip      = print_ip $src->{ip};
18027
5
5
                my $network = $src->{network};
18028
5
14
                if ($src->{mask} == 0xffffffff) {
18029
18030                    # For anyconnect clients.
18031
3
6
                    if ($model->{v8_4}) {
18032
0
0
                        my ($name, $domain) = ($id =~ /^(.*?)(\@.*)$/);
18033
0
0
                        $single_cert_map{$domain} = 1;
18034                    }
18035
18036
3
4
                    my $mask = print_ip $network->{mask};
18037
3
3
                    my $group_policy_name;
18038
3
6
                    if (%$attributes) {
18039
2
2
                        $group_policy_name = "VPN-group-$user_counter";
18040
2
3
                        $print_group_policy->($group_policy_name, $attributes);
18041                    }
18042
3
8
                    print "username $id nopassword\n";
18043
3
5
                    print "username $id attributes\n";
18044
3
6
                    print " vpn-framed-ip-address $ip $mask\n";
18045
3
4
                    print " service-type remote-access\n";
18046
3
5
                    print " vpn-filter value $filter_name\n";
18047
3
7
                    print " vpn-group-policy $group_policy_name\n"
18048                      if $group_policy_name;
18049
3
9
                    print "\n";
18050                }
18051                else {
18052
2
4
                    $pool_name = "pool-$user_counter";
18053
2
3
                    my $mask = print_ip $src->{mask};
18054
2
4
                    my $max =
18055                      print_ip($src->{ip} | complement_32bit $src->{mask});
18056
2
2
                    my $subject_name = delete $attributes->{'check-subject-name'};
18057
2
7
                    if ($id =~ /^@/) {
18058
1
2
                        $subject_name = 'ea';
18059                    }
18060
2
3
                    my $map_name = "ca-map-$user_counter";
18061
2
4
                    print "crypto ca certificate map $map_name 10\n";
18062
2
5
                    print " subject-name attr $subject_name co $id\n";
18063
2
9
                    print "ip local pool $pool_name $ip-$max mask $mask\n";
18064
2
3
                    $attributes->{'vpn-filter'}    = $filter_name;
18065
2
2
                    $attributes->{'address-pools'} = $pool_name;
18066
2
3
                    my $group_policy_name = "VPN-group-$user_counter";
18067
2
4
                    my @tunnel_gen_att =
18068                      ("default-group-policy $group_policy_name");
18069
18070                    # Select attributes for tunnel-group general-attributes.
18071
2
9
                    for my $key (sort keys %$attributes) {
18072
10
9
                        my $spec = $asa_vpn_attributes{$key};
18073
10
28
                        if ($spec && $spec->{tg_general}) {
18074
0
0
                            my $value = delete $attributes->{$key};
18075
0
0
                            my $out = defined($value) ? "$key $value" : $key;
18076
0
0
                            push(@tunnel_gen_att, $out);
18077                        }
18078                    }
18079
18080
2
7
                    my $trustpoint2 = delete $attributes->{'trust-point'}
18081                      || $trust_point;
18082
2
6
                    my @tunnel_ipsec_att =
18083                      $model->{v8_4}
18084                      ? (
18085                        "ikev1 trust-point $trustpoint2",
18086                        'ikev1 user-authentication none'
18087                      )
18088                      : (
18089                        "trust-point $trustpoint2",
18090                        'isakmp ikev1-user-authentication none'
18091                      );
18092
18093
2
4
                    $print_group_policy->($group_policy_name, $attributes);
18094
18095
2
3
                    my $tunnel_group_name = "VPN-tunnel-$user_counter";
18096
2
5
                    print <<"EOF";
18097tunnel-group $tunnel_group_name type remote-access
18098tunnel-group $tunnel_group_name general-attributes
18099EOF
18100
18101
2
2
                    for my $line (@tunnel_gen_att) {
18102
2
5
                        print " $line\n";
18103                    }
18104
2
4
                    print <<"EOF";
18105tunnel-group $tunnel_group_name ipsec-attributes
18106EOF
18107
18108
2
1
                    for my $line (@tunnel_ipsec_att) {
18109
4
9
                        print " $line\n";
18110                    }
18111
18112                    # For anyconnect clients.
18113
2
4
                    if ($model->{v8_4}) {
18114
0
0
                        print <<"EOF";
18115tunnel-group $tunnel_group_name webvpn-attributes
18116 authentication certificate
18117EOF
18118
0
0
                        $cert_group_map{$map_name} = $tunnel_group_name;
18119                    }
18120
18121
2
9
                    print <<"EOF";
18122tunnel-group-map ca-map-$user_counter 10 $tunnel_group_name
18123
18124EOF
18125                }
18126            }
18127        }
18128
18129        # A VPN network.
18130        else {
18131
1
1
            $user_counter++;
18132
18133            # Access list will be bound to cleartext interface.
18134            # Only check for correct source address at vpn-filter.
18135
1
2
            $interface->{intf_rules} = [];
18136
2
5
            $interface->{rules}      = [
18137                map {
18138
1
3
                    {
18139                        src       => $_,
18140                        dst       => $network_00,
18141                        prt       => $prt_ip,
18142                    }
18143
1
1
                  } @{ $interface->{peer_networks} }
18144            ];
18145
1
3
            find_object_groups($router, $interface);
18146
18147            # Define filter ACL to be used in username or group-policy.
18148
1
3
            my $filter_name = "vpn-filter-$user_counter";
18149
1
2
            my $prefix      = "access-list $filter_name extended";
18150
18151
1
2
            print_cisco_acl_add_deny $router, $interface, $no_nat_set, $model,
18152              $prefix;
18153
18154
1
3
            my $id = $interface->{peers}->[0]->{id}
18155              or internal_err("Missing ID at $interface->{peers}->[0]->{name}");
18156
1
2
            my $attributes = $router->{radius_attributes};
18157
18158
1
1
            my $group_policy_name;
18159
1
3
            if (keys %$attributes) {
18160
0
0
                $group_policy_name = "VPN-router-$user_counter";
18161
0
0
                $print_group_policy->($group_policy_name, $attributes);
18162            }
18163
1
3
            print "username $id nopassword\n";
18164
1
2
            print "username $id attributes\n";
18165
1
5
            print " service-type remote-access\n";
18166
1
2
            print " vpn-filter value $filter_name\n";
18167
1
3
            print " vpn-group-policy $group_policy_name\n"
18168              if $group_policy_name;
18169
1
3
            print "\n";
18170        }
18171    }
18172
18173    # Generate certificate-group-map for anyconnect/ikev2 clients.
18174
3
15
    if (keys %cert_group_map or keys %single_cert_map) {
18175
0
0
        for my $id (sort keys %single_cert_map) {
18176
0
0
            $user_counter++;
18177
0
0
            my $map_name = "ca-map-$user_counter";
18178
0
0
            print "crypto ca certificate map $map_name 10\n";
18179
0
0
            print " subject-name attr ea co $id\n";
18180
0
0
            $cert_group_map{$map_name} = $default_tunnel_group;
18181        }
18182
0
0
        print "webvpn\n";
18183
0
0
        for my $map_name (sort keys %cert_group_map) {
18184
0
0
            my $tunnel_group_map = $cert_group_map{$map_name};
18185
0
0
            print " certificate-group-map $map_name 10 $tunnel_group_map\n";
18186        }
18187    }
18188
3
15
    return;
18189}
18190
18191sub iptables_acl_line {
18192
53
0
60
    my ($rule, $no_nat_set, $prefix) = @_;
18193
53
98
    my ($action, $src, $dst, $src_range, $prt) =
18194
53
43
      @{$rule}{qw(action src dst src_range prt)};
18195
53
68
    my $spair = address($src, $no_nat_set);
18196
53
64
    my $dpair = address($dst, $no_nat_set);
18197
53
70
    my $action_code =
18198        is_chain($action) ? $action->{name}
18199      : $action eq 'permit' ? 'ACCEPT'
18200      :                       'droplog';
18201
53
79
    my $jump = $rule->{goto} ? '-g' : '-j';
18202
53
127
    my $result = "$prefix $jump $action_code";
18203
53
111
    if ($spair->[1] != 0) {
18204
35
48
        $result .= ' -s ' . prefix_code($spair);
18205    }
18206
53
97
    if ($dpair->[1] != 0) {
18207
42
52
        $result .= ' -d ' . prefix_code($dpair);
18208    }
18209
53
118
    if ($prt ne $prt_ip) {
18210
49
65
        $result .= ' ' . iptables_prt_code($src_range, $prt);
18211    }
18212
53
103
    print "$result\n";
18213
53
159
    return;
18214}
18215
18216# Pre-processing for all interfaces.
18217sub print_acl_prefix {
18218
246
0
1263
    my ($router) = @_;
18219
246
263
    my $model    = $router->{model};
18220
246
474
    return if $model->{filter} ne 'iptables';
18221
33
30
    my $comment_char = $model->{comment_char};
18222
33
56
    print "$comment_char [ PREFIX ]\n";
18223
33
41
    print "#!/sbin/iptables-restore <<EOF\n";
18224
18225    # Excempt loopback packets from connection tracking.
18226
33
34
    print "*raw\n";
18227
33
36
    print ":PREROUTING ACCEPT\n";
18228
33
33
    print ":OUTPUT ACCEPT\n";
18229
33
36
    print "-A PREROUTING -i lo -j NOTRACK\n";
18230
33
36
    print "-A OUTPUT -o lo -j NOTRACK\n";
18231
33
28
    print "COMMIT\n";
18232
18233    # Start filter table
18234
33
29
    print "*filter\n";
18235
33
34
    print ":INPUT DROP\n";
18236
33
31
    print ":FORWARD DROP\n";
18237
33
33
    print ":OUTPUT ACCEPT\n";
18238
33
36
    print "-A INPUT -j ACCEPT -m state --state ESTABLISHED,RELATED\n";
18239
33
33
    print "-A FORWARD -j ACCEPT -m state --state ESTABLISHED,RELATED\n";
18240
33
33
    print "-A INPUT -j ACCEPT -i lo\n";
18241
18242    # Add user defined chain 'droplog'.
18243
33
32
    print ":droplog -\n";
18244
33
37
    print "-A droplog -j LOG --log-level debug\n";
18245
33
30
    print "-A droplog -j DROP\n";
18246
33
29
    print "\n";
18247
33
37
    return;
18248}
18249
18250sub print_acl_suffix {
18251
246
0
249
    my ($router) = @_;
18252
246
260
    my $model    = $router->{model};
18253
246
489
    return if $model->{filter} ne 'iptables';
18254
33
32
    my $comment_char = $model->{comment_char};
18255
33
52
    print "$comment_char [ SUFFIX ]\n";
18256
33
33
    print "-A INPUT -j droplog\n";
18257
33
34
    print "-A FORWARD -j droplog\n";
18258
33
30
    print "COMMIT\n";
18259
33
30
    print "EOF\n";
18260
33
31
    return;
18261}
18262
18263sub print_iptables_acls {
18264
34
0
34
    my ($router)     = @_;
18265
34
32
    my $model        = $router->{model};
18266
34
29
    my $comment_char = $model->{comment_char};
18267
18268
34
48
    print_chains $router;
18269
18270
34
34
27
50
    for my $hardware (@{ $router->{hardware} }) {
18271
18272        # Ignore if all logical interfaces are loopback interfaces.
18273
60
98
        next if $hardware->{loopback};
18274
18275
58
67
        my $in_hw      = $hardware->{name};
18276
58
53
        my $no_nat_set = $hardware->{no_nat_set};
18277
58
98
        if ($config{comment_acls}) {
18278
18279            # Name of first logical interface
18280
0
0
            print "$comment_char $hardware->{interfaces}->[0]->{name}\n";
18281        }
18282
18283        # Print chain and declaration for interface rules.
18284        # Add call to chain in INPUT chain.
18285
58
85
        my $intf_acl_name = "${in_hw}_self";
18286
58
108
        print ":$intf_acl_name -\n";
18287
58
118
        print "-A INPUT -j $intf_acl_name -i $in_hw\n";
18288
58
77
        my $intf_prefix = "-A $intf_acl_name";
18289
58
58
50
98
        for my $rule (@{ $hardware->{intf_rules} }) {
18290
28
39
            iptables_acl_line($rule, $no_nat_set, $intf_prefix);
18291        }
18292
18293        # Print chain and declaration for forward rules.
18294        # Add call to chain in FORRWARD chain.
18295        # One chain for each pair of in_intf / out_intf.
18296
58
55
        my $rules_hash = $hardware->{io_rules};
18297
58
131
        for my $out_hw (sort keys %$rules_hash) {
18298
22
32
            my $acl_name = "${in_hw}_$out_hw";
18299
22
43
            print ":$acl_name -\n";
18300
22
57
            print "-A FORWARD -j $acl_name -i $in_hw -o $out_hw\n";
18301
22
31
            my $prefix     = "-A $acl_name";
18302
22
30
            my $rules_aref = $rules_hash->{$out_hw};
18303
22
26
            for my $rule (@$rules_aref) {
18304
25
41
                iptables_acl_line($rule, $no_nat_set, $prefix, $model);
18305            }
18306        }
18307
18308        # Empty line after each chain.
18309
58
117
        print "\n";
18310    }
18311
34
47
    return;
18312}
18313
18314sub print_cisco_acls {
18315
214
0
193
    my ($router)     = @_;
18316
214
220
    my $model        = $router->{model};
18317
214
208
    my $filter       = $model->{filter};
18318
214
195
    my $comment_char = $model->{comment_char};
18319
18320
214
214
174
305
    for my $hardware (@{ $router->{hardware} }) {
18321
18322        # Ignore if all logical interfaces are loopback interfaces.
18323
499
820
        next if $hardware->{loopback};
18324
18325        # Ignore layer3 interface of ASA.
18326
486
935
        next if $hardware->{name} eq 'device' && $model->{class} eq 'ASA';
18327
18328        # Force valid array reference to prevent error
18329        # when checking for non empty array.
18330
481
782
        $hardware->{rules} ||= [];
18331
18332
481
713
        if ($model->{can_objectgroup}) {
18333
244
361
            if (not $router->{no_group_code}) {
18334
244
416
                find_object_groups($router, $hardware);
18335            }
18336        }
18337
18338
481
447
        my $no_nat_set = $hardware->{no_nat_set};
18339
18340        # Generate code for incoming and possibly for outgoing ACL.
18341
481
490
        for my $suffix ('in', 'out') {
18342
962
2969
            next if $suffix eq 'out' and not $hardware->{need_out_acl};
18343
18344            # Don't generate single 'permit ip any any'.
18345
496
806
            if (!$model->{need_acl}) {
18346
289
578
296
930
                if (!grep { my $rules = $hardware->{$_} || [];
18347
578
1772
                            @$rules != 1 || $rules->[0] ne $permit_any_rule }
18348                    (qw(rules intf_rules)))
18349                {
18350
8
8
                    next;
18351                }
18352            }                
18353
18354
488
1008
            my $acl_name = "$hardware->{name}_$suffix";
18355
488
456
            my $prefix;
18356
488
782
            if ($config{comment_acls}) {
18357
18358                # Name of first logical interface
18359
0
0
                print "$comment_char $hardware->{interfaces}->[0]->{name}\n";
18360            }
18361
488
1017
            if ($filter eq 'IOS') {
18362
246
221
                $prefix = '';
18363
246
492
                print "ip access-list extended $acl_name\n";
18364            }
18365            elsif ($filter eq 'NX-OS') {
18366
27
27
                $prefix = '';
18367
27
69
                print "ip access-list $acl_name\n";
18368            }
18369            elsif ($filter eq 'ACE') {
18370
8
16
                $prefix = "access-list $acl_name extended";
18371            }
18372            elsif ($filter eq 'PIX') {
18373
207
209
                $prefix      = "access-list $acl_name";
18374
207
434
                $prefix .= ' extended' if $model->{class} eq 'ASA';
18375            }
18376
18377            # Incoming ACL and protect own interfaces.
18378
488
630
            if ($suffix eq 'in') {
18379
473
675
                print_cisco_acl_add_deny(
18380                    $router, $hardware, $no_nat_set, $model, $prefix
18381                );
18382            }
18383
18384            # Outgoing ACL
18385            else {
18386
15
32
                my $out_rules = $hardware->{out_rules} ||= [];
18387
18388                # Add deny rule at end of ACL if not 'permit ip any any'
18389
15
46
                if (!(@$out_rules && $out_rules->[-1] eq $permit_any_rule)) {
18390
14
17
                    push(@$out_rules, $deny_any_rule);
18391                }
18392
15
23
                cisco_acl_line($router, $out_rules, $no_nat_set, $prefix);
18393            }
18394
18395            # Post-processing for hardware interface
18396
488
1509
            if ($filter eq 'IOS' || $filter eq 'NX-OS') {
18397
273
921
                push(
18398
273
235
                    @{ $hardware->{subcmd} },
18399                    "ip access-group $acl_name $suffix"
18400                );
18401            }
18402            elsif ($filter eq 'ACE') {
18403
8
25
                push(
18404
8
9
                    @{ $hardware->{subcmd} },
18405                    "access-group ${suffix}put $acl_name"
18406                );
18407            }
18408            elsif ($filter eq 'PIX') {
18409
207
712
                print "access-group $acl_name $suffix interface",
18410                  " $hardware->{name}\n";
18411            }
18412
18413            # Empty line after each ACL.
18414
488
794
            print "\n";
18415        }
18416    }
18417
214
272
    return;
18418}
18419
18420sub print_acls {
18421
248
0
221
    my ($router)     = @_;
18422
248
241
    my $model        = $router->{model};
18423
248
253
    my $filter       = $model->{filter};
18424
248
236
    my $comment_char = $model->{comment_char};
18425
248
340
    print_header($router, 'ACL');
18426
18427
248
344
    if ($filter eq 'iptables') {
18428
34
47
        print_iptables_acls($router);
18429    }
18430    else {
18431
214
278
        print_cisco_acls($router);
18432    }
18433
248
435
    return;
18434}
18435
18436sub gen_crypto_rules {
18437
10
0
9
    my ($local, $remote) = @_;
18438
10
8
    my @crypto_rules;
18439
10
11
    for my $src (@$local) {
18440
11
9
        for my $dst (@$remote) {
18441
14
44
            push(
18442                @crypto_rules,
18443                {
18444                    src       => $src,
18445                    dst       => $dst,
18446                    prt       => $prt_ip
18447                }
18448            );
18449        }
18450    }
18451
10
17
    return \@crypto_rules;
18452}
18453
18454sub print_ezvpn {
18455
1
0
1
    my ($router)     = @_;
18456
1
2
    my $model        = $router->{model};
18457
1
1
1
2
    my @interfaces   = @{ $router->{interfaces} };
18458
1
4
1
7
    my @tunnel_intf = grep { $_->{ip} eq 'tunnel' } @interfaces;
18459
1
2
    @tunnel_intf == 1 or internal_err();
18460
1
2
    my ($tunnel_intf) = @tunnel_intf;
18461
1
1
    my $wan_intf = $tunnel_intf->{real_interface};
18462
1
1
    my $wan_hw = $wan_intf->{hardware};
18463
1
2
    my $no_nat_set = $wan_hw->{no_nat_set};
18464
1
4
1
15
    my @lan_intf = grep { $_ ne $wan_intf and $_ ne $tunnel_intf } @interfaces;
18465
18466    # Ezvpn configuration.
18467
1
2
    my $ezvpn_name               = 'vpn';
18468
1
1
    my $crypto_acl_name          = 'ACL-Split-Tunnel';
18469
1
1
    my $crypto_filter_name       = 'ACL-crypto-filter';
18470
1
1
    my $virtual_interface_number = 1;
18471
1
3
    print "crypto ipsec client ezvpn $ezvpn_name\n";
18472
1
1
    print " connect auto\n";
18473
1
1
    print " mode network-extension\n";
18474
18475
1
1
1
2
    for my $peer (@{ $tunnel_intf->{peers} }) {
18476
18477        # Unnumbered, negotiated and short interfaces have been
18478        # rejected already.
18479
1
3
        my $peer_ip = prefix_code(address($peer->{real_interface},
18480                                          $no_nat_set));
18481
1
4
        print " peer $peer_ip\n";
18482    }
18483
18484    # Bind split tunnel ACL.
18485
1
2
    print " acl $crypto_acl_name\n";
18486
18487    # Use virtual template defined above.
18488
1
3
    print " virtual-interface $virtual_interface_number\n";
18489
18490    # xauth is unused, but syntactically needed.
18491
1
1
    print " username test pass test\n";
18492
1
1
    print " xauth userid mode local\n";
18493
18494    # Apply ezvpn to WAN and LAN interface.
18495
1
2
    for my $lan_intf (@lan_intf) {
18496
2
3
        my $lan_hw = $lan_intf->{hardware};
18497
2
6
        push(
18498
2
1
            @{ $lan_hw->{subcmd} },
18499            "crypto ipsec client ezvpn $ezvpn_name inside"
18500        );
18501    }
18502
1
1
1
3
    push(@{ $wan_hw->{subcmd} }, "crypto ipsec client ezvpn $ezvpn_name");
18503
18504    # Crypto ACL controls which traffic needs to be encrypted.
18505
1
3
    $tunnel_intf->{crypto}->{detailed_crypto_acl}
18506      and internal_err("Unexpected attribute 'detailed_crypto_acl'",
18507        " at $router->{name}");
18508
1
3
    my $crypto_rules =
18509      gen_crypto_rules($tunnel_intf->{peers}->[0]->{peer_networks},
18510        [$network_00]);
18511
1
3
    print "ip access-list extended $crypto_acl_name\n";
18512
1
1
    my $prefix     = '';
18513
1
2
    cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix);
18514
18515    # Crypto filter ACL.
18516
1
1
    $prefix = '';
18517
1
3
    $tunnel_intf->{intf_rules} ||= [];
18518
1
7
    $tunnel_intf->{rules} ||= [];
18519
1
2
    print "ip access-list extended $crypto_filter_name\n";
18520
1
2
    print_cisco_acl_add_deny($router, $tunnel_intf, $no_nat_set, $model,
18521                             $prefix);
18522
18523    # Bind crypto filter ACL to virtual template.
18524
1
2
    print "interface Virtual-Template$virtual_interface_number type tunnel\n";
18525
1
4
    $crypto_filter_name
18526      and print " ip access-group $crypto_filter_name in\n";
18527
1
3
    return;
18528}
18529
18530# Print crypto ACL.
18531# It controls which traffic needs to be encrypted.
18532sub print_crypto_acl {
18533
9
0
10
    my ($interface, $suffix, $crypto, $crypto_type) = @_;
18534
9
12
    my $crypto_acl_name = "crypto-$suffix";
18535
9
8
    my $prefix;
18536
9
17
    if ($crypto_type eq 'IOS') {
18537
1
1
        $prefix = '';
18538
1
3
        print "ip access-list extended $crypto_acl_name\n";
18539    }
18540    elsif ($crypto_type eq 'ASA') {
18541
8
15
        $prefix = "access-list $crypto_acl_name extended";
18542    }
18543    else {
18544
0
0
        internal_err();
18545    }
18546
18547    # Print crypto ACL entries.
18548    # - either generic from remote network to any or
18549    # - detailed to all networks which are used in rules.
18550
9
9
    my $is_hub   = $interface->{is_hub};
18551
9
13
    my $hub      = $is_hub ? $interface : $interface->{peers}->[0];
18552
9
10
    my $detailed = $crypto->{detailed_crypto_acl};
18553
9
15
    my $local = $detailed ? get_split_tunnel_nets($hub) : [$network_00];
18554
9
8
    my $remote = $hub->{peer_networks};
18555
9
18
    $is_hub or ($local, $remote) = ($remote, $local);
18556
9
11
    my $crypto_rules = gen_crypto_rules($local, $remote);
18557
9
11
    my $router = $interface->{router};
18558
9
7
    my $no_nat_set = $interface->{no_nat_set};
18559
9
14
    cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix);
18560
9
24
    return $crypto_acl_name;
18561}
18562
18563# Print filter ACL. It controls which traffic is allowed to leave from
18564# crypto tunnel. This may be needed, if we don't fully trust our peer.
18565sub print_crypto_filter_acl {
18566
9
0
11
    my ($interface, $suffix, $crypto_type) = @_;
18567
9
9
    my $router = $interface->{router};
18568
18569
9
17
    return if $router->{no_crypto_filter};
18570
18571
1
2
    my $prefix;
18572
1
2
    my $crypto_filter_name = "crypto-filter-$suffix";
18573
1
2
    if ($crypto_type eq 'IOS') {
18574
1
1
        $prefix = '';
18575
1
3
        print "ip access-list extended $crypto_filter_name\n";
18576    }
18577    else {
18578
0
0
        internal_err();
18579    }
18580
1
2
    my $model  = $router->{model};
18581
1
1
    my $no_nat_set = $interface->{no_nat_set};
18582
1
2
    print_cisco_acl_add_deny($router, $interface, $no_nat_set, $model, $prefix);
18583
1
6
    return $crypto_filter_name;
18584}
18585
18586# Called for static and dynamic crypto maps.
18587sub print_crypto_map_attributes {
18588
9
0
16
    my ($prefix, $model, $crypto_type, $crypto_acl_name, $crypto_filter_name,
18589        $isakmp, $ipsec, $ipsec2trans_name) = @_;
18590
18591    # Bind crypto ACL to crypto map.
18592
9
20
    print "$prefix match address $crypto_acl_name\n";
18593
18594    # Bind crypto filter ACL to crypto map.
18595
9
18
    if ($crypto_filter_name) {
18596
1
3
        print "$prefix set ip access-group $crypto_filter_name in\n";
18597    }
18598
18599
9
12
    my $transform_name = $ipsec2trans_name->{$ipsec};
18600
9
13
    if ($crypto_type eq 'ASA') {
18601
8
18
        if ($isakmp->{ike_version} == 2) {
18602
2
5
            print "$prefix set ikev2 ipsec-proposal $transform_name\n";
18603        }
18604        elsif ($model->{v8_4}) {
18605
2
5
            print "$prefix set ikev1 transform-set $transform_name\n";
18606        }
18607        else {
18608
4
9
            print "$prefix set transform-set $transform_name\n";
18609        }
18610    }
18611    else {
18612
1
2
        print "$prefix set transform-set $transform_name\n";
18613    }                
18614
18615
9
24
    if (my $pfs_group = $ipsec->{pfs_group}) {
18616
9
20
        print "$prefix set pfs group$pfs_group\n";
18617    }
18618
18619
9
18
    if (my $lifetime = $ipsec->{lifetime}) {
18620
18621        # Don't print default value for backend IOS.
18622
9
24
        if (not($lifetime == 3600 and $crypto_type eq 'IOS')) {
18623
8
23
            print("$prefix set security-association",
18624                  " lifetime seconds $lifetime\n");
18625        }
18626    }
18627
9
12
    return;
18628}
18629
18630sub print_tunnel_group {
18631
8
0
9
    my ($name, $interface, $isakmp) = @_;
18632
8
8
    my $model  = $interface->{router}->{model};
18633
8
8
    my $no_nat_set = $interface->{no_nat_set};
18634
8
8
    my $authentication = $isakmp->{authentication};
18635
8
18
    print "tunnel-group $name type ipsec-l2l\n";
18636
8
14
    print "tunnel-group $name ipsec-attributes\n";
18637
8
11
    if ($authentication eq 'rsasig') {
18638
6
7
        my $trust_point = $isakmp->{trust_point};
18639
6
12
        if ($isakmp->{ike_version} == 2) {
18640
2
5
            print(" ikev2 local-authentication certificate",
18641                  " $trust_point\n");
18642
2
3
            print(" ikev2 remote-authentication certificate\n");
18643        }
18644        elsif ($model->{v8_4}) {
18645
2
5
            print " ikev1 trust-point $trust_point\n";
18646
2
4
            print " ikev1 user-authentication none\n";
18647        }
18648        else {
18649
2
5
            print " trust-point $trust_point\n";
18650
2
3
            print " isakmp ikev1-user-authentication none\n";
18651        }
18652    }
18653
18654    # Preshared key is configured manually.
18655    else {
18656
2
3
        print " peer-id-validate nocheck\n";
18657    }
18658
8
14
    return;
18659}
18660
18661sub print_ca_and_tunnel_group_map {
18662
6
0
5
    my ($id, $tg_name) = @_;
18663
18664    # Activate tunnel-group with tunnel-group-map.
18665    # Use $id as ca-map name.
18666
6
13
    print "crypto ca certificate map $id 10\n";
18667
6
11
    print " subject-name attr ea eq $id\n";
18668
6
14
    print "tunnel-group-map $id 10 $tg_name\n";
18669
6
16
    return;
18670}
18671
18672sub print_static_crypto_map {
18673
5
0
8
    my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_;
18674
5
5
    my $model = $router->{model};
18675
5
5
    my $crypto_type = $model->{crypto};
18676
5
6
    my $hw_name = $hardware->{name};
18677
18678    # Sequence number for parts of crypto map with different peers.
18679
5
5
    my $seq_num = 0;
18680
18681    # Crypto ACLs and peer IP must obey NAT.
18682
5
4
    my $no_nat_set = $hardware->{no_nat_set};
18683
18684    # Sort crypto maps by peer IP to get deterministic output.
18685
5
2
8
7
    my @sorted = sort({ $a->{peers}->[0]->{real_interface}->{ip}
18686                        <=>
18687                        $b->{peers}->[0]->{real_interface}->{ip}
18688                      }
18689                      @$interfaces);
18690
18691    # Build crypto map for each tunnel interface.
18692
5
6
    for my $interface (@sorted) {
18693
7
7
        $seq_num++;
18694
7
15
        my $suffix = "$hw_name-$seq_num";
18695
18696
7
8
        my $crypto = $interface->{crypto};
18697
7
8
        my $ipsec  = $crypto->{type};
18698
7
7
        my $isakmp = $ipsec->{key_exchange};
18699
18700
7
10
        my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto,
18701                                               $crypto_type);
18702
7
11
        my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix,
18703                                                         $crypto_type);
18704
18705
18706        # Define crypto map.
18707
7
6
        my $prefix;
18708
7
15
        if ($crypto_type eq 'IOS') {
18709
1
2
            $prefix = '';
18710
1
8
            print "crypto map $map_name $seq_num ipsec-isakmp\n";
18711        }
18712        elsif ($crypto_type eq 'ASA') {
18713
6
14
            $prefix = "crypto map $map_name $seq_num";
18714        }
18715
18716        # Set crypto peers.
18717
7
15
        if ($crypto_type eq 'IOS') {
18718
1
1
1
1
            for my $peer (@{ $interface->{peers} }) {
18719
1
2
                my $peer_ip = prefix_code(address($peer->{real_interface},
18720                                                  $no_nat_set));
18721
1
4
                print "$prefix set peer $peer_ip\n";
18722            }
18723        }
18724        elsif ($crypto_type eq 'ASA') {
18725
6
12
            print "$prefix set peer ",
18726            join(' ',
18727
6
7
                 map { prefix_code(address($_->{real_interface},
18728                                           $no_nat_set)) }
18729
6
8
                 @{ $interface->{peers} }),
18730            "\n";
18731        }
18732
18733
7
13
        print_crypto_map_attributes($prefix, $model, $crypto_type,
18734                                    $crypto_acl_name, $crypto_filter_name,
18735                                    $isakmp, $ipsec, $ipsec2trans_name);
18736
18737
18738
7
12
        if ($crypto_type eq 'ASA') {
18739
6
6
4
11
            for my $peer (@{ $interface->{peers} }) {
18740
6
10
                my $peer_ip = prefix_code(address($peer->{real_interface},
18741                                                  $no_nat_set));
18742
6
10
                print_tunnel_group($peer_ip, $interface, $isakmp);
18743
18744                # Tunnel group needs to be activated, if certificate
18745                # is in use.
18746
6
16
                if (my $id = $peer->{id}) {
18747
4
6
                    print_ca_and_tunnel_group_map($id, $peer_ip);
18748                }
18749            }
18750        }
18751    }
18752
5
7
    return;
18753}
18754
18755sub print_dynamic_crypto_map {
18756
1
0
2
    my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_;
18757
1
1
    my $model = $router->{model};
18758
1
2
    my $crypto_type = $model->{crypto};
18759
1
2
    $crypto_type eq 'ASA' or internal_err();
18760
1
2
    my $hw_name = $hardware->{name};
18761
18762    # Sequence number for parts of crypto map with different certificates.
18763
1
1
    my $seq_num = 65536;
18764
18765    # Sort crypto maps by certificate to get deterministic output.
18766
1
1
2
3
    my @sorted = sort({ $a->{peers}->[0]->{id} cmp $b->{peers}->[0]->{id} }
18767                      @$interfaces);
18768
18769    # Build crypto map for each tunnel interface.
18770
1
2
    for my $interface (@sorted) {
18771
2
2
        $seq_num--;
18772
2
5
        my $suffix = "$hw_name-$seq_num";
18773
2
4
        my $id = $interface->{peers}->[0]->{id};
18774
18775
2
2
        my $crypto = $interface->{crypto};
18776
2
2
        my $ipsec  = $crypto->{type};
18777
2
2
        my $isakmp = $ipsec->{key_exchange};
18778
18779
2
4
        my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto,
18780                                               $crypto_type);
18781
2
3
        my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix,
18782                                                         $crypto_type);
18783
18784        # Define dynamic crypto map.
18785        # Use certificate as name.
18786
2
5
        my $prefix = "crypto dynamic-map $id 10";
18787
18788
2
3
        print_crypto_map_attributes($prefix, $model, $crypto_type,
18789                                    $crypto_acl_name, $crypto_filter_name,
18790                                    $isakmp, $ipsec, $ipsec2trans_name);
18791
18792        # Bind dynamic crypto map to crypto map.
18793
2
5
        $prefix = "crypto map $map_name $seq_num";
18794
2
5
        print "$prefix ipsec-isakmp dynamic $id\n";
18795
18796        # Use $id as tunnel-group name
18797
2
3
        print_tunnel_group($id, $interface, $isakmp);
18798
18799        # Activate tunnel-group with tunnel-group-map.
18800
2
3
        print_ca_and_tunnel_group_map($id, $id);
18801    }
18802
1
2
    return;
18803}
18804
18805sub print_crypto {
18806
248
0
228
    my ($router) = @_;
18807
248
604
    my $model = $router->{model};
18808
248
534
    my $crypto_type = $model->{crypto} || '';
18809
18810    # List of ipsec definitions used at current router.
18811    # Sort entries by name to get deterministic output.
18812
13
24
    my @ipsec = sort by_name unique(
18813
612
1969
        map { $_->{crypto}->{type} }
18814
248
248
250
338
        grep { $_->{ip} eq 'tunnel' } @{ $router->{interfaces} }
18815    );
18816
18817    # Return if no crypto is used at current router.
18818
248
727
    return unless @ipsec;
18819
18820    # List of isakmp definitions used at current router.
18821    # Sort entries by name to get deterministic output.
18822
10
13
11
21
    my @isakmp = sort by_name unique(map { $_->{key_exchange} } @ipsec);
18823
18824
10
12
    my $comment_char = $model->{comment_char};
18825
10
12
    print_header($router, 'Crypto');
18826
18827
10
19
    if ($crypto_type eq 'EZVPN') {
18828
1
3
        print_ezvpn $router;
18829
1
3
        return;
18830    }
18831
18832    # Use interface access lists to filter incoming crypto traffic.
18833    # Group policy and per-user authorization access list can't be used
18834    # because they are stateless.
18835
9
25
    if ($crypto_type =~ /^ASA/) {
18836
8
11
        print "! VPN traffic is filtered at interface ACL\n";
18837
8
10
        print "no sysopt connection permit-vpn\n";
18838    }
18839
18840
9
17
    if ($crypto_type eq 'ASA_VPN') {
18841
3
7
        print_asavpn $router;
18842
3
7
        return;
18843    }
18844
18845    # Crypto config for ASA as EZVPN client is configured manually once.
18846    # No config is generated by netspoc.
18847
6
8
    if ($crypto_type eq 'ASA_EZVPN') {
18848
0
0
        return;
18849    }
18850
18851
6
20
    $crypto_type =~ /^(:?IOS|ASA)$/
18852      or internal_err("Unexptected crypto type $crypto_type");
18853
18854
6
6
    my $isakmp_count = 0;
18855
6
9
    for my $isakmp (@isakmp) {
18856
18857        # Only print isakmp for IOS. Approve for ASA will ignore it anyway.
18858
9
18
        $crypto_type eq 'IOS' or next;
18859
18860
1
2
        $isakmp_count++;
18861
1
3
        print "crypto isakmp policy $isakmp_count\n";
18862
18863
1
1
        my $authentication = $isakmp->{authentication};
18864
1
2
        $authentication =~ s/preshare/pre-share/;
18865
1
4
        $authentication =~ s/rsasig/rsa-sig/;
18866
18867        # Don't print default value for backend IOS.
18868
1
3
        if (not($authentication eq 'rsa-sig')) {
18869
0
0
            print " authentication $authentication\n";
18870        }
18871
18872
1
2
        my $encryption = $isakmp->{encryption};
18873
1
5
        if ($encryption =~ /^aes(\d+)$/) {
18874
1
4
            my $len = $crypto_type eq 'ASA' ? "-$1" : " $1";
18875
1
2
            $encryption = "aes$len";
18876        }
18877
1
2
        print " encryption $encryption\n";
18878
1
2
        my $hash = $isakmp->{hash};
18879
1
2
        print " hash $hash\n";
18880
1
2
        my $group = $isakmp->{group};
18881
1
2
        print " group $group\n";
18882
18883
1
1
        my $lifetime = $isakmp->{lifetime};
18884
18885        # Don't print default value for backend IOS.
18886
1
3
        if (not($lifetime == 86400)) {
18887
1
3
            print " lifetime $lifetime\n";
18888        }
18889    }
18890
18891    # Handle IPSEC definition.
18892
6
6
    my $transform_count = 0;
18893
6
7
    my %ipsec2trans_name;
18894
6
7
    for my $ipsec (@ipsec) {
18895
9
7
        $transform_count++;
18896
9
15
        my $transform_name = "Trans$transform_count";
18897
9
12
        $ipsec2trans_name{$ipsec} = $transform_name;
18898
9
10
        my $isakmp = $ipsec->{key_exchange};
18899
18900        # IKEv2 syntax for ASA.
18901
9
30
        if ($crypto_type eq 'ASA' and $isakmp->{ike_version} == 2) {
18902
2
5
            print "crypto ipsec ikev2 ipsec-proposal $transform_name\n";
18903
2
11
            if (my $ah = $ipsec->{ah}) {
18904
0
0
                print " protocol ah $ah\n";
18905            }
18906
2
2
            my $esp_encr;
18907
2
16
            if (not(my $esp = $ipsec->{esp_encryption})) {
18908
0
0
                $esp_encr = 'null';
18909            }
18910            elsif ($esp =~ /^(aes|des|3des)$/) {
18911
0
0
                $esp_encr = $1;
18912            }
18913            elsif ($esp =~ /^aes(192|256)$/) {
18914
2
4
                $esp_encr = "aes-$1";
18915            }
18916
2
4
            print " protocol esp encryption $esp_encr\n";
18917
2
5
            if (my $esp_ah = $ipsec->{esp_authentication}) {
18918
2
9
                $esp_ah =~ s/^(.+?)(\d+)/$1-$2/;
18919
2
9
                print " protocol esp integrity $esp_ah\n";
18920            }
18921        }
18922
18923        # IKEv1 syntax of ASA is identical to IOS.
18924        else {
18925
7
11
            my $transform = '';
18926
7
10
            if (my $ah = $ipsec->{ah}) {
18927
0
0
                $transform .= "ah-$ah-hmac ";
18928            }
18929
7
41
            if (not(my $esp = $ipsec->{esp_encryption})) {
18930
0
0
                $transform .= 'esp-null ';
18931            }
18932            elsif ($esp =~ /^(aes|des|3des)$/) {
18933
3
7
                $transform .= "esp-$1 ";
18934            }
18935            elsif ($esp =~ /^aes(192|256)$/) {
18936
4
10
                my $len = $crypto_type eq 'ASA' ? "-$1" : " $1";
18937
4
9
                $transform .= "esp-aes$len ";
18938            }
18939
7
18
            if (my $esp_ah = $ipsec->{esp_authentication}) {
18940
7
12
                $transform .= "esp-$esp_ah-hmac";
18941            }
18942
7
24
            my $prefix = ($crypto_type eq 'ASA' and $model->{v8_4})
18943                       ? 'crypto ipsec ikev1'
18944                       : 'crypto ipsec';
18945
7
26
            print "$prefix transform-set $transform_name $transform\n";
18946        }
18947    }
18948
18949    # Collect tunnel interfaces attached to each hardware interface.
18950    # Differentiate on peers having static or dynamic IP address.
18951
6
7
    my %hardware2crypto;
18952    my %hardware2dyn_crypto;
18953
6
6
5
9
    for my $interface (@{ $router->{interfaces} }) {
18954
21
36
        $interface->{ip} eq 'tunnel' or next;
18955
9
13
        my $ip = $interface->{peers}->[0]->{real_interface}->{ip};
18956
9
20
        if ($ip =~ /^(?:negotiated|short|unnumbered)$/) {
18957
2
2
3
5
            push @{ $hardware2dyn_crypto{ $interface->{hardware} } }, $interface;
18958        }
18959        else {
18960
7
7
3
21
            push @{ $hardware2crypto{ $interface->{hardware} } }, $interface;
18961        }
18962    }
18963
18964
6
6
6
10
    for my $hardware (@{ $router->{hardware} }) {
18965
12
11
        my $hw_name = $hardware->{name};
18966
18967        # Name of crypto map.
18968
12
13
        my $map_name = "crypto-$hw_name";
18969
18970
12
12
        my $have_crypto_map;
18971
12
22
        if (my $interfaces =  $hardware2crypto{$hardware}) {
18972
5
11
            print_static_crypto_map($router, $hardware, $map_name, $interfaces,
18973                                    \%ipsec2trans_name);
18974
5
4
            $have_crypto_map = 1;
18975        }
18976
12
23
        if (my $interfaces =  $hardware2dyn_crypto{$hardware}) {
18977
1
2
            print_dynamic_crypto_map($router, $hardware, $map_name, $interfaces,
18978                                    \%ipsec2trans_name);
18979
1
1
            $have_crypto_map = 1;
18980        }
18981
18982        # Bind crypto map to interface.
18983
12
22
        $have_crypto_map or next;
18984
6
13
        if ($crypto_type eq 'IOS') {
18985
1
1
1
4
            push(@{ $hardware->{subcmd} }, "crypto map $map_name");
18986        }
18987        elsif ($crypto_type eq 'ASA') {
18988
5
19
            print "crypto map $map_name interface $hw_name\n";
18989        }
18990    }
18991
6
23
    return;
18992}
18993
18994sub print_interface {
18995
248
0
224
    my ($router) = @_;
18996
248
256
    my $model = $router->{model};
18997
248
523
    return if !$model->{print_interface};
18998
122
134
    my $class = $model->{class};
18999
122
151
    my $stateful = not $model->{stateless};
19000
122
122
115
174
    for my $hardware (@{ $router->{hardware} }) {
19001
291
312
        my $name = $hardware->{name};
19002
291
515
        next if $name eq 'VIP' and $model->{has_vip};
19003
289
227
        my @subcmd;
19004        my $secondary;
19005
0
0
        my $addr_cmd;
19006
289
289
224
357
        for my $intf (@{ $hardware->{interfaces} }) {
19007
319
312
            my $ip = $intf->{ip};
19008
319
847
            if ($ip eq 'tunnel') {
19009
0
0
                next;
19010            }
19011            elsif ($ip eq 'unnumbered') {
19012
4
5
                $addr_cmd = 'ip unnumbered X';
19013            }
19014            elsif ($ip eq 'negotiated') {
19015
1
1
                $addr_cmd = 'ip address negotiated';
19016            }
19017            elsif ($model->{use_prefix}) {
19018
37
46
                my $addr = print_ip($ip);
19019
37
61
                my $mask = mask2prefix($intf->{network}->{mask});
19020
37
63
                $addr_cmd = "ip address $addr/$mask";
19021
37
70
                $addr_cmd .= ' secondary' if $secondary;
19022            }
19023            else {
19024
277
338
                my $addr = print_ip($ip);
19025
277
420
                my $mask = print_ip($intf->{network}->{mask});
19026
277
438
                $addr_cmd = "ip address $addr $mask";
19027
277
472
                $addr_cmd .= ' secondary' if $secondary;
19028            }
19029
319
307
            push @subcmd, $addr_cmd;
19030
319
456
            $secondary = 1;
19031        }
19032
289
517
        if (my $vrf = $router->{vrf}) {
19033
4
6
            if ($class eq 'NX-OS') {
19034
4
5
                push @subcmd, "vrf member $vrf";
19035            }
19036            else {
19037
0
0
                push @subcmd, "ip vrf forwarding $vrf";
19038            }
19039        }
19040
19041        # Add "ip inspect" as marker, that stateful filtering is expected.
19042        # The command is known to be incomplete, "X" is only used as
19043        # placeholder.
19044
289
1172
        if ($class eq 'IOS' && $stateful && !$hardware->{loopback}) {
19045
167
161
            push @subcmd, "ip inspect X in";
19046        }
19047
289
469
        if (my $other = $hardware->{subcmd}) {
19048
270
271
            push @subcmd, @$other;
19049        }
19050
19051        # Split name for ACE: "vlan3029" -> "vlan 3029"
19052
289
469
        $name =~ s/(\d+)/ $1/ if ($class eq 'ACE');
19053
19054
289
535
        print "interface $name\n";
19055
289
342
        for my $cmd (@subcmd) {
19056
775
1572
            print " $cmd\n";
19057        }
19058    }
19059
122
150
    print "\n";
19060
122
226
    return;
19061}
19062
19063# Make output directory available.
19064sub check_output_dir {
19065
310
0
308
    my ($dir) = @_;
19066
310
1249
    unless (-e $dir) {
19067
0
0
        mkdir $dir
19068          or fatal_err("Can't create output directory $dir: $!");
19069    }
19070
310
792
    -d $dir or fatal_err("$dir isn't a directory");
19071
310
322
    return;
19072}
19073
19074# Print generated code for each managed router.
19075sub print_code {
19076
155
0
184
    my ($dir) = @_;
19077
19078    # Untaint $dir. This is necessary if running setuid.
19079    # We can trust value of $dir because it is set by setuid wrapper.
19080
155
515
    ($dir) = ($dir =~ /(.*)/);
19081
155
276
    check_output_dir($dir);
19082
19083
155
201
    progress('Printing code');
19084
155
128
    my %seen;
19085
155
206
    for my $router (@managed_routers, @routing_only_routers) {
19086
261
543
        next if $seen{$router};
19087
19088        # Ignore splitted part.
19089
258
430
        next if $router->{orig_router};
19090
19091
249
313
        my $device_name = $router->{device_name};
19092
249
211
        my $file = $device_name;
19093
19094        # Untaint $file. It has already been checked for word characters,
19095        # but check again for the case of a weird locale setting.
19096
249
545
        $file =~ /^(.*)/;
19097
249
602
        $file = "$dir/$1";
19098
19099        ## no critic (RequireBriefOpen)
19100
249
6126
        open(my $code_fd, '>', $file)
19101            or fatal_err("Can't open $file for writing: $!");
19102
249
670
        select $code_fd;
19103
19104
249
334
        my $model        = $router->{model};
19105
249
274
        my $comment_char = $model->{comment_char};
19106
19107        # Restore interfaces of splitted router.
19108
249
443
        if (my $orig_interfaces = $router->{orig_interfaces}) {
19109
9
10
            $router->{interfaces} = $orig_interfaces;
19110
9
14
            $router->{hardware} = $router->{orig_hardware};
19111        }
19112
19113        # Collect VRF members.
19114
249
185
        my $vrf_members;
19115
249
394
        if (my $members = $router->{vrf_members}) {
19116
3
5
            $vrf_members = $members;
19117
3
14
            $seen{$_} = 1 for @$members;
19118        }
19119        else {
19120
246
360
            $vrf_members = [ $router ];
19121        }
19122
19123
249
2036
        print "$comment_char Generated by $program, version $version\n\n";
19124
249
571
        print "$comment_char [ BEGIN $device_name ]\n";
19125
249
489
        print "$comment_char [ Model = $model->{class} ]\n";
19126
249
439
        if ($router->{policy_distribution_point}) {
19127
7
7
7
11
9
22
            my @ips = map({ my $ips = $_->{admin_ip}; $ips ? @$ips : (); }
19128                          @$vrf_members);
19129
7
16
            if (@ips) {
19130
7
48
                printf("$comment_char [ IP = %s ]\n", join(',', @ips));
19131            }
19132        }
19133        my $per_vrf = sub {
19134
1233
1060
            my($call) = @_;
19135
1233
1292
            for my $vrouter (@$vrf_members) {
19136
1244
1546
                $call->($vrouter);
19137            }
19138
249
803
        };
19139
249
407
        if ($router->{managed}) {
19140
246
427
            $per_vrf->(\&print_routes);
19141
246
438
            $per_vrf->(\&print_crypto);
19142
246
422
            print_acl_prefix($router);
19143
246
364
            $per_vrf->(\&print_acls);
19144
246
390
            print_acl_suffix($router);
19145
246
377
            $per_vrf->(\&print_interface);
19146
246
387
            $per_vrf->(\&print_nat);
19147        }
19148        else {
19149
3
5
            $per_vrf->(\&print_routes);
19150        }
19151
19152
249
566
        print "$comment_char [ END $device_name ]\n\n";
19153
249
310
        select STDOUT;
19154
249
5839
        close $code_fd or fatal_err("Can't close $file: $!");
19155        ## use critic
19156
19157    }
19158
155
255
    return;
19159}
19160
19161sub copy_raw {
19162
155
0
224
    my ($in_path, $out_dir) = @_;
19163
155
939
    return if ! (defined $in_path && -d $in_path);
19164
155
247
    return if ! defined $out_dir;
19165
19166    # Untaint $in_path, $out_dir. This is necessary if running setuid.
19167    # Trusted because set by setuid wrapper.
19168
155
515
    ($in_path) = ($in_path =~ /(.*)/);
19169
155
319
    ($out_dir) = ($out_dir =~ /(.*)/);
19170
155
232
    check_output_dir($out_dir);
19171
19172
155
236
    my $raw_dir = "$in_path/raw";
19173
155
840
    return if not -d $raw_dir;
19174
19175    # Clean PATH if run in taint mode.
19176    ## no critic (RequireLocalizedPunctuationVars)
19177
0
0
    $ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
19178    ## use critic
19179
19180
0
0
    my %device_names =
19181
0
0
        map { $_->{device_name} => 1 } @managed_routers, @routing_only_routers;
19182
19183
0
0
    opendir(my $dh, $raw_dir) or fatal_err("Can't opendir $raw_dir: $!");
19184
0
0
    while (my $file = Encode::decode($filename_encode, readdir $dh)) {
19185
0
0
        next if $file  =~ /^\./;
19186
0
0
        next if $file =~ m/$config{ignore_files}/o;
19187
19188        # Untaint $file.
19189
0
0
        my ($raw_file) = ($file =~ /^(.*)/);
19190
0
0
        my $raw_path = "$raw_dir/$raw_file";
19191
0
0
        if (not -f $raw_path) {
19192
0
0
            warn_msg("Ignoring $raw_path");
19193
0
0
            next;
19194        }
19195
0
0
        if (not $device_names{$file}) {
19196
0
0
            warn_msg("Found unused $raw_path");
19197
0
0
            next;
19198        }
19199
0
0
        my $copy = "$out_dir/$raw_file.raw";
19200
0
0
        system("cp -f $raw_path $copy") == 0
19201          or fatal_err("Can't copy $raw_path to $copy: $!");
19202    }
19203
0
0
    return;
19204}
19205
19206sub show_version {
19207
318
0
753
    progress("$program, version $version");
19208
318
298
    return;
19209}
19210
19211sub show_finished {
19212
208
0
381
    progress('Finished') if $config{time_stamps};
19213
208
177
    return;
19214}
19215
19216# These must be initialized on each run, because protocols are changed
19217# by prepare_prt_ordering.
19218sub init_protocols {
19219
19220
375
0
1229
    %routing_info = (
19221        EIGRP => {
19222            name  => 'EIGRP',
19223            prt   => { name => 'auto_prt:EIGRP', proto => 88 },
19224            mcast => [
19225                new(
19226                    'Network',
19227                    name => "auto_network:EIGRP_multicast",
19228                    ip   => gen_ip(224, 0, 0, 10),
19229                    mask => gen_ip(255, 255, 255, 255)
19230                )
19231                ]
19232        },
19233        OSPF => {
19234            name  => 'OSPF',
19235            prt   => { name => 'auto_prt:OSPF', proto => 89 },
19236            mcast => [
19237                new(
19238                    'Network',
19239                    name => "auto_network:OSPF_multicast5",
19240                    ip   => gen_ip(224, 0, 0, 5),
19241                    mask => gen_ip(255, 255, 255, 255),
19242                ),
19243                new(
19244                    'Network',
19245                    name => "auto_network:OSPF_multicast6",
19246                    ip   => gen_ip(224, 0, 0, 6),
19247                    mask => gen_ip(255, 255, 255, 255)
19248                )
19249                ]
19250        },
19251        dynamic => { name => 'dynamic' },
19252
19253        # Identical to 'dynamic', but must only be applied to router.
19254        manual => { name => 'manual' },
19255    );
19256
375
1159
    %xxrp_info = (
19257        VRRP => {
19258            prt   => { name => 'auto_prt:VRRP', proto => 112 },
19259            mcast => new(
19260                'Network',
19261                name => "auto_network:VRRP_multicast",
19262                ip   => gen_ip(224, 0, 0, 18),
19263                mask => gen_ip(255, 255, 255, 255)
19264            )
19265        },
19266        HSRP => {
19267            prt => {
19268                name      => 'auto_prt:HSRP',
19269                proto     => 'udp',
19270                dst_range => [ 1985, 1985 ],
19271            },
19272            mcast => new(
19273                'Network',
19274                name => "auto_network:HSRP_multicast",
19275                ip   => gen_ip(224, 0, 0, 2),
19276                mask => gen_ip(255, 255, 255, 255)
19277            )
19278        },
19279        HSRPv2 => {
19280            prt => {
19281                name      => 'auto_prt:HSRPv2',
19282                proto     => 'udp',
19283                dst_range => [ 1985, 1985 ],
19284            },
19285            mcast => new(
19286                'Network',
19287                name => "auto_network:HSRPv2_multicast",
19288                ip   => gen_ip(224, 0, 0, 102),
19289                mask => gen_ip(255, 255, 255, 255)
19290            )
19291        },
19292    );
19293
19294
375
836
    $prt_ip = { name => 'auto_prt:ip', proto => 'ip' };
19295
375
578
    $prt_icmp = {
19296        name  => 'auto_prt:icmp',
19297        proto => 'icmp'
19298    };
19299
375
806
    $prt_tcp = {
19300        name      => 'auto_prt:tcp',
19301        proto     => 'tcp',
19302        dst_range => $aref_tcp_any
19303    };
19304
375
732
    $prt_udp = {
19305        name      => 'auto_prt:udp',
19306        proto     => 'udp',
19307        dst_range => $aref_tcp_any
19308    };
19309
375
869
    $prt_bootps = {
19310        name      => 'auto_prt:bootps',
19311        proto     => 'udp',
19312        dst_range => [ 67, 67]
19313    };
19314
375
1082
    $prt_ike = {
19315        name      => 'auto_prt:IPSec_IKE',
19316        proto     => 'udp',
19317        src_range => [ 500, 500 ],
19318        dst_range => [ 500, 500 ]
19319    };
19320
375
1130
    $prt_natt = {
19321        name      => 'auto_prt:IPSec_NATT',
19322        proto     => 'udp',
19323        src_range => [ 4500, 4500 ],
19324        dst_range => [ 4500, 4500 ]
19325    };
19326
375
748
    $prt_esp = { name => 'auto_prt:IPSec_ESP', proto => 50, prio => 100, };
19327
375
707
    $prt_ah = { name => 'auto_prt:IPSec_AH', proto => 51, prio => 99, };
19328
375
801
    $deny_any_rule = {
19329        deny      => 1,
19330        src       => $network_00,
19331        dst       => $network_00,
19332        prt       => $prt_ip
19333    };
19334
375
634
    $permit_any_rule = {
19335        src       => $network_00,
19336        dst       => $network_00,
19337        prt       => $prt_ip
19338    };
19339
375
505
    return;
19340}
19341
19342sub init_global_vars {
19343
375
0
813
    $start_time = time();
19344
375
344
    $error_counter = 0;
19345
375
343
    $abort_immediately = undef;
19346
375
320
    $new_store_description = 0;
19347
375
837
    for my $pair (values %global_type) {
19348
4875
4875
3331
6494
        %{ $pair->[1] } = ();
19349    }
19350
375
824
    %interfaces = %hosts = ();
19351
375
578
    @managed_routers = @routing_only_routers = @router_fragments = ();
19352
375
525
    @virtual_interfaces = @pathrestrictions = ();
19353
375
730
    @managed_crypto_hubs = @routers = @networks = @zones = @areas = ();
19354
375
365
    @natdomains = ();
19355
375
375
    %auto_interfaces = ();
19356
375
348
    $from_json = undef;
19357
375
537
    %crypto2spokes = %crypto2hubs = ();
19358
375
371
    %rule_tree = ();
19359
375
8419
    %prt_hash = %ref2prt = %ref2obj = %token2regex = ();
19360
375
438
    %ref2obj = %ref2prt = ();
19361
375
385
    %obj2zone = ();
19362
375
366
    %obj2path = ();
19363
375
341
    %key2obj = ();
19364
375
353
    %border2obj2auto = ();
19365
375
351
    %filter_networks = ();
19366
375
344
    @deleted_rules = ();
19367
375
451
    %unknown2services = %unknown2unknown = ();
19368
375
413
    %supernet_rule_tree = %missing_supernet = ();
19369
375
361
    %smaller_prt = ();
19370
375
409
    %known_log = %key2log = ();
19371
375
537
    init_protocols();
19372
375
419
    return;
19373}
19374
19375# Call once when module is loaded.
19376# Call again, before different input is processed by same instance.
19377init_global_vars();
19378
19379####################################################################
19380# Argument processing
19381# Get option names from %config.
19382# Write options back to %config.
19383####################################################################
19384
19385
70
70
70
25307
114
361
use Getopt::Long qw(GetOptionsFromArray);
19386
70
70
70
15783
126
62673
use Pod::Usage;
19387
19388sub parse_options {
19389
305
0
260
    my ($args) = @_;
19390
305
245
    my %result;
19391    my $setopt = sub {
19392
3
3
        my ($key, $val) = @_;
19393
3
6
        if (my $expected = check_config_pair($key, $val)) {
19394
0
0
            die "Value '$val' invalid for option $key ($expected expected)\n";
19395        }
19396
3
9
        $result{$key} = $val;
19397
305
1180
    };
19398
19399
305
287
    my %options;
19400
305
429
    for my $key (get_config_keys()) {
19401
5185
5887
        my $opt = get_config_pattern($key) eq '0|1' ? '!' : '=s';
19402
5185
9188
        $options{"$key$opt"} = $setopt;
19403    }
19404
305
305
1147
675
    $options{quiet} = sub { $result{verbose} = 0 };
19405
305
0
670
0
    $options{'help|?'} = sub { pod2usage(1) };
19406
305
0
642
0
    $options{man} = sub { pod2usage(-exitstatus => 0, -verbose => 2) };
19407
19408
305
1506
    if (!GetOptionsFromArray($args, %options)) {
19409
19410        # Don't use 'exit' but 'die', so we can catch this error in tests.
19411
0
0
        my $out;
19412
0
0
        open(my $fh, '>', \$out) or die $!;
19413
0
0
        pod2usage(-exitstatus => 'NOEXIT', -verbose => 0, -output => $fh);
19414
0
0
        close $fh;
19415
0
0
        die($out || '');
19416    }
19417
19418
305
2711
    return \%result;
19419}
19420
19421sub parse_args {
19422
305
0
279
    my ($args) = @_;
19423
305
350
    my $main_file = shift @$args;
19424
19425    # Strip trailing slash for nicer messages.
19426
305
673
    defined $main_file and $main_file =~ s</$><>;
19427
19428    # $out_dir is used to store compilation results.
19429    # For each managed router with name X a corresponding file X
19430    # is created in $out_dir.
19431    # If $out_dir is missing, all code is printed to STDOUT.
19432
305
274
    my $out_dir = shift @$args;
19433
19434    # Strip trailing slash for nicer messages.
19435
305
493
    defined $out_dir and $out_dir =~ s</$><>;
19436
19437    # No further arguments allowed.
19438
305
460
    @$args and pod2usage(2);
19439
305
534
    return ($main_file, $out_dir);
19440}
19441
19442sub compile {
19443
305
0
289
    my ($args) = @_;
19444
19445
305
478
    my($cmd_config) = &parse_options($args);
19446
305
507
    my($in_path, $out_dir) = &parse_args($args);
19447
305
494
    my $file_config = &read_config($in_path);
19448
19449    # Command line options override options from 'config' file.
19450    # Rightmost overrides.
19451
305
501
    &set_config($file_config, $cmd_config);
19452
19453    # Don't compile but check only for errors if no $out_dir is given.
19454
305
420
    &fast_mode(!$out_dir);
19455
305
421
    &show_version();
19456
305
427
    &read_file_or_dir($in_path);
19457
305
424
    &show_read_statistics();
19458
305
412
    &order_protocols();
19459
305
422
    &link_topology();
19460
305
441
    &mark_disabled();
19461
305
464
    &set_zone();
19462
305
441
    &setpath();
19463
300
422
    &distribute_nat_info();
19464
300
437
    find_subnets_in_zone();
19465
300
398
    &set_service_owner();
19466
300
436
    &expand_services(1);    # 1: expand hosts to subnets
19467
19468    # Abort now, if there are syntax errors and simple semantic errors.
19469
300
414
    &abort_on_error();
19470
226
327
    &expand_crypto();
19471
226
305
    &check_unused_groups();
19472
226
641
    set_policy_distribution_ip();
19473
226
363
    &optimize_and_warn_deleted();
19474
226
321
    &check_supernet_rules();
19475
226
325
    prepare_nat_commands();
19476
226
372
    find_active_routes();
19477
226
330
    &gen_reverse_rules();
19478
226
327
    &mark_secondary_rules();
19479
226
296
    mark_dynamic_nat_rules();
19480
226
292
    &abort_on_error();
19481
208
276
    &set_abort_immediately();
19482
208
299
    &rules_distribution();
19483
208
318
    &local_optimization();
19484
208
351
    if ($out_dir) {
19485
155
263
        &print_code($out_dir);
19486
155
253
        copy_raw($in_path, $out_dir);
19487    }
19488
208
297
    show_finished();
19489
208
546
    return;
19490}
19491
194921;
19493
19494#  LocalWords:  Netspoc Knutzen internet CVS IOS iproute iptables STDERR Perl
19495#  LocalWords:  netmask EOL ToDo IPSec unicast utf hk src dst ICMP IPs EIGRP
19496#  LocalWords:  OSPF VRRP HSRP Arnes loop's ISAKMP stateful ACLs negatable
19497#  LocalWords:  STDOUT